home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / fortran / toolpack.000 / toolpack / toolpack1.2 / access / YXLIB.MAC.f < prev   
Encoding:
Text File  |  1993-10-04  |  128.2 KB  |  4,030 lines
  1. C---------------------------------------------------------
  2. C    TOOLPACK/1    Release: 2.5
  3. C---------------------------------------------------------
  4. C YXLIB Customisation Parameters
  5. C ------------------------------
  6.  
  7. C Routine Names
  8. C -------------
  9.  
  10. C Field Definitions: Parse Tree Attributes
  11. C ----------------------------------------
  12. C Note: The high-order bit in the word (bit 31 in a 32-bit machine) MUST
  13. C       NOT BE USED, as ordinary arithmetic is used to extract some fields
  14.  
  15. C Attribute Table Macros
  16. C ----------------------
  17.  
  18. C YXLIB Bits
  19. C ----------
  20.  
  21. C YXLIB Local Record Macros
  22. C -------------------------
  23. C   type VARX = record
  24. C                   su: integer;    (* Storage units for variable *)
  25. C                   common: ^(S_COMMON) or -maxint..-1;
  26. C                                   (* ^(common block symbol), nil (0) or
  27. C                                      negative of equivalence class number *)
  28. C                   comsize: integer;(* Offset in common or equiv class *)
  29. C                   equiv: ^EQV;    (* Pointer to equivalence link *)
  30. C                   if SYMBOL(var_arr_decl)<>0 then array: ARRAYX
  31. C                                   (* array information stored here *)
  32. C               end;
  33. C
  34. C   type ARRAYX = record
  35. C                   elts: integer;  (* Number of elements in the array *)
  36. C                   dims: integer;  (* Number of dimensions of the array *)
  37. C                   limits: array [1..dims] of
  38. C                               record LOWER,UPPER: integer end
  39. C                 end;
  40.  
  41.  
  42. C   type EQH = HEAD record          (* Equivalence head record *)
  43. C                       common: ^(S_COMMON) or -maxint..-1;
  44. C                       usage: set of usage_bits
  45. C                   end;
  46.  
  47. C   type EQV = LINK record          (* Equivalence variable record (link) *)
  48. C                       sudif: integer;
  49. C                       symbol: ^(S_VAR)
  50. C                   end;
  51.  
  52. C   type LPR = record
  53. C                   glob: ^(GPU) or -^(GEX);
  54. C                   nargs: integer;
  55. C                   args: array [1..nargs] of packed record
  56. C                               dtype: min_dtype..max_dtype;
  57. C                               argument_type: atype;
  58. C                               descendents: ^HEAD;
  59. C                               if dtype=type_char then
  60. C                                   min_length, max_length: integer
  61. C                               end if
  62. C                           end record
  63. C              end;
  64.  
  65. C                                   (* Argument type definitions *)
  66. C   type ATYPE = (scalar,arelm,array,proc,label);
  67. C   const min_atype = scalar; max_atype = label;
  68.  
  69. C YXLIB Record Definition: Semi-Local
  70. C -----------------------------------
  71. C   type PAREC = LINK record
  72. C                   argnum: integer; (* Argument number passed down as *)
  73. C                   prsym: ^(S_PROC); (* Procedure passed down to *)
  74. C                   argsym: ^symbol; (* Actual argument being passed down *)
  75. C                   pusym: ^(S_PU); (* Associating program-unit (context) *)
  76. C                   stmtno: integer; (* Statement number of assoc (context) *)
  77. C                end;
  78.  
  79. C   type UNSAF = LINK record
  80. C                   code: 1..5;     (* Type of unsafe reference to be checked *)
  81. C                   argnum: integer;(* Argument number applicable *)
  82. C                   extra: anything;(* Extra data (not used by inherit_expr) *)
  83. C                   pusym: ^(S_PU); (* Context: associating program-unit *)
  84. C                   stmtno: integer;(* Context: statement number *)
  85. C                   prsym: ^(S_PROC)(* proc being called *)
  86. C                end;
  87.  
  88. C YXLIB Global Record Macros
  89. C --------------------------
  90. C
  91. C   type G_COM = record             Global common block record
  92. C                   size: integer;
  93. C                   type: (character,numeric,mixed); (* logical = numeric *)
  94. C                   save: (saved,not_saved,only_in_main);
  95. C                   init: integer   (* Number of times init'ed by block data *)
  96. C                end;
  97.  
  98. C
  99. C   type G_PU = record              Global program-unit record
  100. C                   dtype: integer;
  101. C                   chrlen: integer;
  102. C                   culist: ^HEAD;  (* common block usage list header ptr *)
  103. C                   nargs: integer;
  104. C                   descend: ^HEAD; (* descendent routine list header ptr *)
  105. C                   entrys: ^(HEAD) record ^G_ENT end;
  106. C                   args: array [1..nargs] of gpuarg
  107. C               end;
  108.  
  109. C   type G_ENT = record
  110. C                   dtype: integer;
  111. C                   chrlen: integer;
  112. C                   pu: ^G_PU;
  113. C                   nargs: integer;
  114. C                   descend: ^HEAD; (* descendent routine list header ptr *)
  115. C                   args: array [1..nargs] of ^guparg
  116. C                end;
  117.  
  118. C type gpuarg = record
  119. C                   dtype,chlen: integer;
  120. C                   usage: (arg,read,update);
  121. C                   struc: (scal,array,proc,label);
  122. C                   size: integer;
  123. C                   pass: ^HEAD;
  124. C                   inh: ^HEAD(inherit)
  125. C               end;
  126. C type inherit = record
  127. C                   type: (proc,expr,dupl,comm,sfa,doix,arg);
  128. C                   ass: ^(GPU);    (* associating program-unit *)
  129. C                   snum: integer;  (* statement number of association *)
  130. C                   if (type=proc) then
  131. C                       gsyptr: ^(GPU)/-^(GEX)
  132. C                   else
  133. C                       extra: integer (* unsafe ref extra data *)
  134. C                   end if
  135.  
  136.  
  137. C Global Descendant Routine Types
  138. C -------------------------------
  139.  
  140. C Error Codes returned by YXLIB
  141. C -----------------------------
  142.  
  143.  
  144.  
  145.  
  146.  
  147.  
  148.  
  149.  
  150. C                                   parameter length
  151.  
  152.  
  153.  
  154.  
  155.  
  156.  
  157.  
  158. C---------------------------------------------------------
  159. C    TOOLPACK/1    Release: 2.5
  160. C---------------------------------------------------------
  161. C ----------------------------------------------------------------------
  162. C
  163. C       $ I N I _ A T T R I B   -   Initialise attribute table
  164. C
  165.  
  166.         SUBROUTINE ZYXZIA
  167.  
  168. C---------------------------------------------------------
  169. C    TOOLPACK/1    Release: 2.5
  170. C---------------------------------------------------------
  171.         COMMON/XCATRX/SYMATR,ATRGLB
  172.         INTEGER SYMATR(69000),ATRGLB
  173.         SAVE /XCATRX/
  174. C---------------------------------------------------------
  175. C    TOOLPACK/1    Release: 2.5
  176. C---------------------------------------------------------
  177.         COMMON/XCPAHP/USHEAD,PAHEAD,PAHEAP
  178.         INTEGER USHEAD,PAHEAD,PAHEAP(11000)
  179.  
  180.         SAVE /XCPAHP/
  181.  
  182.         INTEGER HALLOC,LLCRHE
  183.         EXTERNAL HINIT,HALLOC,LLCRHE
  184.  
  185. C Note: The attribute table uses the HEAP sub-library, and so the
  186. C       number of the highest element in use is in SYMATR(2).
  187. C
  188. C The global attribute pointer is in ATRGLB, and points to a block
  189. C whose elements contain:
  190. C                    (1) The Program-Unit Chain
  191. C                    (2) The Common Block Chain
  192. C                    (3) The External References Chain
  193. C                    (4) The ENTRY Point Chain
  194. C These are actually zero or pointers to the HEAD record for that chain.
  195.  
  196.         CALL HINIT(SYMATR,69000)
  197.         CALL HINIT(PAHEAP,11000)
  198.         PAHEAD=LLCRHE(PAHEAP,0)
  199.         USHEAD=LLCRHE(PAHEAP,0)
  200.         ATRGLB=HALLOC(SYMATR,4)
  201.         SYMATR(ATRGLB+0)=0
  202.         SYMATR(ATRGLB+1)=0
  203.         SYMATR(ATRGLB+2)=0
  204.         SYMATR(ATRGLB+3)=0
  205.  
  206.         END
  207. C ----------------------------------------------------------------------
  208. C
  209. C       $ O U T _ A T T R I B   -   Output attribute table
  210. C
  211.  
  212.         SUBROUTINE ZYXOAS(IOD)
  213.         INTEGER IOD
  214.  
  215. C---------------------------------------------------------
  216. C    TOOLPACK/1    Release: 2.5
  217. C---------------------------------------------------------
  218.         COMMON/XCATRX/SYMATR,ATRGLB
  219.         INTEGER SYMATR(69000),ATRGLB
  220.         SAVE /XCATRX/
  221.  
  222.         INTEGER I
  223.  
  224.         EXTERNAL ZPTINT,PUTCH,REMARK
  225.  
  226.         IF (SYMATR(ATRGLB+0).EQ.0)
  227.      +      CALL REMARK('No global attributes set')
  228.         CALL ZPTINT(SYMATR(2),1,IOD)
  229.         CALL PUTCH(32,IOD)
  230.         CALL ZPTINT(ATRGLB,1,IOD)
  231.         CALL PUTCH(10,IOD)
  232.         DO 100 I=1,SYMATR(2)
  233.             CALL ZPTINT(SYMATR(I),1,IOD)
  234.             CALL PUTCH(44,IOD)
  235.  100    CONTINUE
  236.         CALL PUTCH(10,IOD)
  237.  
  238.         END
  239. C ----------------------------------------------------------------------
  240. C
  241. C       $ R E A D _ A T T R I B   -   Read attribute table
  242. C
  243.  
  244.         SUBROUTINE ZYXRAB(IODATR)
  245.         INTEGER IODATR
  246.  
  247. C---------------------------------------------------------
  248. C    TOOLPACK/1    Release: 2.5
  249. C---------------------------------------------------------
  250.         COMMON/XCATRX/SYMATR,ATRGLB
  251.         INTEGER SYMATR(69000),ATRGLB
  252.         SAVE /XCATRX/
  253.  
  254.         INTEGER BUFF(134),PNTR,I,JUNK,J
  255.  
  256.         INTEGER ZSCTOI,GETLIN,GETCH
  257.         EXTERNAL ZSCTOI,GETLIN,GETCH,ERROR
  258.  
  259.         JUNK=GETLIN(BUFF,IODATR)
  260.         PNTR=1
  261.         SYMATR(2)=ZSCTOI(BUFF,PNTR)
  262.         IF (SYMATR(2).GT.69000) CALL ERROR('Too many attributes')
  263.         ATRGLB=ZSCTOI(BUFF,PNTR)
  264.         DO 300 I=1,SYMATR(2)
  265.             J=0
  266.  100        J=J+1
  267.  200        BUFF(J)=GETCH(JUNK,IODATR)
  268.             IF (JUNK.EQ.10) GOTO 200
  269.             IF (JUNK.NE.44) GOTO 100
  270.             PNTR=1
  271.             SYMATR(I)=ZSCTOI(BUFF,PNTR)
  272.  300    CONTINUE
  273.  
  274.         END
  275. C ----------------------------------------------------------------------
  276. C
  277. C       $ S E T _ V A L U E   -   Set the value of a tree node
  278. C
  279.  
  280.         SUBROUTINE ZYXSVA(NODE,VALUE)
  281.         INTEGER NODE,VALUE
  282.  
  283. C---------------------------------------------------------
  284. C    TOOLPACK/1    Release: 2.5
  285. C---------------------------------------------------------
  286.         COMMON/XCTREE/ROOT,TREE,TRETOP
  287.         INTEGER ROOT,TREE(4,46339),TRETOP
  288.  
  289.         SAVE /XCTREE/
  290. C---------------------------------------------------------
  291. C    TOOLPACK/1    Release: 2.5
  292. C---------------------------------------------------------
  293.         COMMON/XCATRX/SYMATR,ATRGLB
  294.         INTEGER SYMATR(69000),ATRGLB
  295.         SAVE /XCATRX/
  296.  
  297.         INTEGER APTR
  298.  
  299.         INTEGER XZYAAB
  300.  
  301.         EXTERNAL ERROR
  302.  
  303.         IF (MOD(TREE(4,NODE),262144).NE.0)
  304.      +      CALL ERROR('ZYXSVA: Attempt to change node value')
  305.         APTR=XZYAAB(1)
  306.         SYMATR(APTR)=VALUE
  307.         TREE(4,NODE)=TREE(4,NODE)+APTR
  308.  
  309.         END
  310. C ----------------------------------------------------------------------
  311. C
  312. C       $ D S E T _ V A L U E   -   Set the value of a tree node (DATA)
  313. C
  314.  
  315.         SUBROUTINE ZYXDSV(NODE,VALUE)
  316.         INTEGER NODE,VALUE
  317.  
  318. C---------------------------------------------------------
  319. C    TOOLPACK/1    Release: 2.5
  320. C---------------------------------------------------------
  321.         COMMON/XCTREE/ROOT,TREE,TRETOP
  322.         INTEGER ROOT,TREE(4,46339),TRETOP
  323.  
  324.         SAVE /XCTREE/
  325. C---------------------------------------------------------
  326. C    TOOLPACK/1    Release: 2.5
  327. C---------------------------------------------------------
  328.         COMMON/XCATRX/SYMATR,ATRGLB
  329.         INTEGER SYMATR(69000),ATRGLB
  330.         SAVE /XCATRX/
  331.  
  332.         INTEGER APTR
  333.  
  334.         INTEGER XZYAAB
  335.  
  336.         IF (MOD(TREE(4,NODE),262144).NE.0) THEN
  337.             APTR=MOD(TREE(4,NODE),262144)
  338.         ELSE
  339.             APTR=XZYAAB(1)
  340.         END IF
  341.         SYMATR(APTR)=VALUE
  342.         IF (MOD(TREE(4,NODE),262144).EQ.0)
  343.      +      TREE(4,NODE)=TREE(4,NODE)+APTR
  344.  
  345.         END
  346. C ----------------------------------------------------------------------
  347. C
  348. C       $ G E T _ V A L U E   -   Return value of the parse tree node
  349. C
  350.  
  351.         INTEGER FUNCTION ZYXGVA(NODE)
  352.         INTEGER NODE
  353.  
  354. C---------------------------------------------------------
  355. C    TOOLPACK/1    Release: 2.5
  356. C---------------------------------------------------------
  357.         COMMON/XCTREE/ROOT,TREE,TRETOP
  358.         INTEGER ROOT,TREE(4,46339),TRETOP
  359.  
  360.         SAVE /XCTREE/
  361. C---------------------------------------------------------
  362. C    TOOLPACK/1    Release: 2.5
  363. C---------------------------------------------------------
  364.         COMMON/XCATRX/SYMATR,ATRGLB
  365.         INTEGER SYMATR(69000),ATRGLB
  366.         SAVE /XCATRX/
  367.  
  368.         INTEGER ATRPTR
  369.  
  370.         INTRINSIC MOD
  371.         EXTERNAL ERROR
  372.  
  373.         ATRPTR=MOD(TREE(4,NODE),262144)
  374.         IF (ATRPTR.EQ.0) CALL ERROR('ZYXGVA: No value')
  375.         ZYXGVA=SYMATR(ATRPTR)
  376.  
  377.         END
  378. C ----------------------------------------------------------------------
  379. C
  380. C       $ S E T _ D T Y P E   -   Set the data-type of a parse tree node
  381. C
  382.  
  383.         SUBROUTINE ZYXSDT(NODE,DTYPE)
  384.         INTEGER NODE,DTYPE
  385.  
  386. C---------------------------------------------------------
  387. C    TOOLPACK/1    Release: 2.5
  388. C---------------------------------------------------------
  389.         COMMON/XCTREE/ROOT,TREE,TRETOP
  390.         INTEGER ROOT,TREE(4,46339),TRETOP
  391.  
  392.         SAVE /XCTREE/
  393.  
  394.         EXTERNAL ERROR
  395.  
  396.         IF (TREE(4,NODE).GE.67108864)
  397.      +      CALL ERROR('ZYXSDT: Datatype already set')
  398.         TREE(4,NODE)=TREE(4,NODE)+DTYPE*67108864
  399.  
  400.         END
  401. C ----------------------------------------------------------------------
  402. C
  403. C       $ D S E T _ D T Y P E   -   Set the data-type of a node (DATA)
  404. C
  405.  
  406.         SUBROUTINE ZYXDST(NODE,DTYPE)
  407.         INTEGER NODE,DTYPE
  408.  
  409. C---------------------------------------------------------
  410. C    TOOLPACK/1    Release: 2.5
  411. C---------------------------------------------------------
  412.         COMMON/XCTREE/ROOT,TREE,TRETOP
  413.         INTEGER ROOT,TREE(4,46339),TRETOP
  414.  
  415.         SAVE /XCTREE/
  416.  
  417.         EXTERNAL ERROR
  418.  
  419.         IF (TREE(4,NODE).GE.67108864) THEN
  420.             IF (TREE(4,NODE)/67108864.NE.DTYPE)
  421.      +          CALL ERROR('ZYXDST: Attempt to change datatype')
  422.         ELSE
  423.             TREE(4,NODE)=TREE(4,NODE)+DTYPE*67108864
  424.         END IF
  425.  
  426.         END
  427. C ----------------------------------------------------------------------
  428. C
  429. C       $ G E T _ D T Y P E   -   Return datatype of a parse tree node
  430. C
  431.  
  432.         INTEGER FUNCTION ZYXGDT(NODE)
  433.         INTEGER NODE
  434.  
  435. C---------------------------------------------------------
  436. C    TOOLPACK/1    Release: 2.5
  437. C---------------------------------------------------------
  438.         COMMON/XCTREE/ROOT,TREE,TRETOP
  439.         INTEGER ROOT,TREE(4,46339),TRETOP
  440.  
  441.         SAVE /XCTREE/
  442.  
  443.         EXTERNAL ERROR
  444.  
  445.         ZYXGDT=TREE(4,NODE)/67108864
  446.         IF (ZYXGDT.EQ.0) CALL ERROR('ZYXGDT: No datatype')
  447.  
  448.         END
  449. C ----------------------------------------------------------------------
  450. C
  451. C       $ S E T _ T R E E B I T   -   Set parse tree node status bit(s)
  452. C
  453.  
  454.         SUBROUTINE ZYXSTB(NODE,BVAL)
  455.         INTEGER NODE,BVAL
  456.  
  457. C---------------------------------------------------------
  458. C    TOOLPACK/1    Release: 2.5
  459. C---------------------------------------------------------
  460.         COMMON/XCTREE/ROOT,TREE,TRETOP
  461.         INTEGER ROOT,TREE(4,46339),TRETOP
  462.  
  463.         SAVE /XCTREE/
  464.  
  465.         INTEGER ZIOR
  466.         EXTERNAL ZIOR
  467.  
  468.         TREE(4,NODE)=ZIOR(TREE(4,NODE),BVAL)
  469.  
  470.         END
  471. C ----------------------------------------------------------------------
  472. C
  473. C       $ G E T _ T R E E B I T   -   Return parse tree node status bits
  474. C
  475.  
  476.         INTEGER FUNCTION ZYXGTB(NODE)
  477.         INTEGER NODE
  478.  
  479. C---------------------------------------------------------
  480. C    TOOLPACK/1    Release: 2.5
  481. C---------------------------------------------------------
  482.         COMMON/XCTREE/ROOT,TREE,TRETOP
  483.         INTEGER ROOT,TREE(4,46339),TRETOP
  484.  
  485.         SAVE /XCTREE/
  486.  
  487.         ZYXGTB=TREE(4,NODE)
  488.  
  489.         END
  490. C ----------------------------------------------------------------------
  491. C
  492. C       $ A D D T O _ C O M   -   Add variable to COMMON block list
  493. C
  494.  
  495.         INTEGER FUNCTION ZYXATC(COMPTR,VARPTR)
  496.         INTEGER COMPTR,VARPTR
  497.  
  498. C---------------------------------------------------------
  499. C    TOOLPACK/1    Release: 2.5
  500. C---------------------------------------------------------
  501.         COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
  502.         INTEGER NSYMS,NPUS,PUIDX(250),
  503.      +          SYMBOL(8,5003)
  504.         LOGICAL MODFLG
  505.  
  506.         SAVE /XCSYMS/
  507. C---------------------------------------------------------
  508. C    TOOLPACK/1    Release: 2.5
  509. C---------------------------------------------------------
  510.         COMMON/XCATRX/SYMATR,ATRGLB
  511.         INTEGER SYMATR(69000),ATRGLB
  512.         SAVE /XCATRX/
  513.  
  514.         INTEGER NDIMS,PTR,VARX,ASIZE,TMP(2)
  515.  
  516.         INTEGER XZYAAB,ZYXSU
  517.  
  518.         INTEGER LLCRED,LLCRHE
  519.         EXTERNAL LLCRED,LLINTO,LLCRHE
  520.  
  521. C---------------------------------------------------------
  522. C    TOOLPACK/1    Release: 2.5
  523. C---------------------------------------------------------
  524. C
  525. C Common block and access functions for YP parse tree
  526. C
  527. C---------------------------------------------------------
  528. C    TOOLPACK/1    Release: 2.5
  529. C---------------------------------------------------------
  530.         COMMON/XCTREE/ROOT,TREE,TRETOP
  531.         INTEGER ROOT,TREE(4,46339),TRETOP
  532.  
  533.         SAVE /XCTREE/
  534. C Use "JABC12" to try to avoid conflicts with ordinary variables
  535.         INTEGER NEXT,PREV,UP,DOWN,NATTR,NTYPE,JABC12
  536.  
  537.         NEXT(JABC12)=MOD(TREE(3,JABC12),46340)
  538.         PREV(JABC12)=(TREE(3,JABC12)/46340)
  539.         UP(JABC12)=(TREE(1,JABC12)/46340)
  540.         DOWN(JABC12)=TREE(2,JABC12)
  541.         NTYPE(JABC12)=MOD(TREE(1,JABC12),46340)
  542.         NATTR(JABC12)=TREE(4,JABC12)
  543.  
  544. C Work out how big to make the var-atr-blk if it doesn't yet exist
  545.         IF (SYMBOL(8,VARPTR).EQ.0) THEN
  546.             IF (SYMBOL(7,VARPTR).NE.0) THEN
  547.                 NDIMS=0
  548.                 PTR=SYMBOL(7,VARPTR)
  549.  100            NDIMS=NDIMS+1
  550.                 PTR=NEXT(PTR)
  551.                 IF (PTR.NE.0) GOTO 100
  552.                 ASIZE=NDIMS*2+6
  553.             ELSE
  554.                 ASIZE=4
  555.             END IF
  556.             SYMBOL(8,VARPTR)=XZYAAB(ASIZE)
  557.         END IF
  558. C Get the variable's attribute block
  559.         VARX=SYMBOL(8,VARPTR)
  560. C Make sure it isn't already in some other common block
  561.         IF (SYMATR(VARX+1).NE.0) THEN
  562.             ZYXATC=-1
  563.             RETURN
  564.         END IF
  565. C Okay, say it is in this one
  566.         SYMATR(VARX+1)=COMPTR
  567. C If we can do it now, work out how big the variable is
  568.         IF (SYMBOL(7,VARPTR).EQ.0 .AND.
  569.      +      SYMBOL(5,VARPTR).GE.0) THEN
  570. C .. ie if not an array and any character length was a simple constant
  571.             IF (SYMBOL(5,VARPTR).EQ.0) THEN
  572.                 SYMATR(VARX)=ZYXSU(SYMBOL(4,VARPTR))
  573.             ELSE
  574.                 SYMATR(VARX)=SYMBOL(5,VARPTR)
  575.             END IF
  576.         END IF
  577. C If this is the first element then we need to create the list header
  578.         IF (SYMBOL(7,COMPTR).EQ.0)
  579.      +      SYMBOL(7,COMPTR)=LLCRHE(SYMATR,1)
  580. C Now create a new element in the list of variables in that common block
  581.         TMP(1)=VARPTR
  582.         CALL LLINTO(SYMATR,LLCRED(SYMATR,1,TMP),
  583.      +              SYMBOL(7,COMPTR))
  584. C That's all folks.
  585.         ZYXATC=-2
  586.  
  587.         END
  588. C ----------------------------------------------------------------------
  589. C
  590. C       $ S E T _ A R D I M S   -   Set array dimension data in attr blk
  591. C
  592.  
  593.         SUBROUTINE ZYXSAD(SYMPTR,NDIMS,LOWER,UPPER,ADJP,INFP)
  594.         INTEGER SYMPTR,NDIMS,LOWER(NDIMS),UPPER(NDIMS)
  595.         LOGICAL ADJP,INFP
  596.  
  597. C---------------------------------------------------------
  598. C    TOOLPACK/1    Release: 2.5
  599. C---------------------------------------------------------
  600.         COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
  601.         INTEGER NSYMS,NPUS,PUIDX(250),
  602.      +          SYMBOL(8,5003)
  603.         LOGICAL MODFLG
  604.  
  605.         SAVE /XCSYMS/
  606. C---------------------------------------------------------
  607. C    TOOLPACK/1    Release: 2.5
  608. C---------------------------------------------------------
  609.         COMMON/XCATRX/SYMATR,ATRGLB
  610.         INTEGER SYMATR(69000),ATRGLB
  611.         SAVE /XCATRX/
  612.  
  613.         INTEGER ELTS,I,ARRAYX
  614.  
  615.         INTEGER XZYAAB,ZYXSU
  616.  
  617.         IF (SYMBOL(8,SYMPTR).EQ.0)
  618.      +      SYMBOL(8,SYMPTR)=XZYAAB(NDIMS*2+6)
  619.         ARRAYX=SYMBOL(8,SYMPTR)+4
  620.         SYMATR(ARRAYX+1)=NDIMS
  621.         IF (INFP) SYMATR(ARRAYX+1)=
  622.      +      SYMATR(ARRAYX+1)+2048
  623.         IF (ADJP) SYMATR(ARRAYX+1)=
  624.      +      SYMATR(ARRAYX+1)+1024
  625.         ELTS=1
  626.         DO 100 I=1,NDIMS
  627.             SYMATR(ARRAYX+I*2)=LOWER(I)
  628.             SYMATR(ARRAYX+I*2+1)=UPPER(I)
  629.             ELTS=ELTS*(UPPER(I)-LOWER(I)+1)
  630.  100    CONTINUE
  631.         IF (.NOT.(INFP.OR.ADJP)) THEN
  632.             SYMATR(ARRAYX+0)=ELTS
  633. C Set storage units if we know it easily
  634.             IF (SYMBOL(5,SYMPTR).EQ.0) THEN
  635.                 SYMATR(SYMBOL(8,SYMPTR))=
  636.      +              ELTS*ZYXSU(SYMBOL(4,SYMPTR))
  637.             ELSE IF (SYMBOL(5,SYMPTR).GT.0) THEN
  638.                 SYMATR(SYMBOL(8,SYMPTR))=
  639.      +              ELTS*SYMBOL(5,SYMPTR)
  640.             END IF
  641.         END IF
  642.  
  643.         END
  644. C ----------------------------------------------------------------------
  645. C
  646. C       $ G E T _ E L T S   -   Return number of elements in an array
  647. C
  648.  
  649.         INTEGER FUNCTION ZYXGEL(SYMPTR)
  650.         INTEGER SYMPTR
  651.  
  652. C---------------------------------------------------------
  653. C    TOOLPACK/1    Release: 2.5
  654. C---------------------------------------------------------
  655.         COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
  656.         INTEGER NSYMS,NPUS,PUIDX(250),
  657.      +          SYMBOL(8,5003)
  658.         LOGICAL MODFLG
  659.  
  660.         SAVE /XCSYMS/
  661. C---------------------------------------------------------
  662. C    TOOLPACK/1    Release: 2.5
  663. C---------------------------------------------------------
  664.         COMMON/XCATRX/SYMATR,ATRGLB
  665.         INTEGER SYMATR(69000),ATRGLB
  666.         SAVE /XCATRX/
  667.  
  668.         EXTERNAL ERROR
  669.  
  670.         IF (SYMBOL(8,SYMPTR).LE.0)
  671.      +      CALL ERROR('ZYXGEL: Unknown 124 inapplicable')
  672.         ZYXGEL=SYMATR(SYMBOL(8,SYMPTR)+4)
  673.  
  674.         END
  675. C ----------------------------------------------------------------------
  676. C
  677. C       $ G E T _ A R D I M S   -   Get array dimension information
  678. C
  679.  
  680.         LOGICAL FUNCTION ZYXGAD(SYMPTR,NSUBS,LIMITS,ADJP,INFP)
  681.         INTEGER SYMPTR,NSUBS,LIMITS(2,*)
  682.         LOGICAL ADJP,INFP
  683.  
  684. C---------------------------------------------------------
  685. C    TOOLPACK/1    Release: 2.5
  686. C---------------------------------------------------------
  687.         COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
  688.         INTEGER NSYMS,NPUS,PUIDX(250),
  689.      +          SYMBOL(8,5003)
  690.         LOGICAL MODFLG
  691.  
  692.         SAVE /XCSYMS/
  693. C---------------------------------------------------------
  694. C    TOOLPACK/1    Release: 2.5
  695. C---------------------------------------------------------
  696.         COMMON/XCATRX/SYMATR,ATRGLB
  697.         INTEGER SYMATR(69000),ATRGLB
  698.         SAVE /XCATRX/
  699.  
  700.         INTEGER I,PTR
  701.  
  702.         INTEGER ZIAND
  703.         EXTERNAL ZIAND
  704.  
  705.         IF (SYMBOL(8,SYMPTR).EQ.0) THEN
  706.             ZYXGAD=.FALSE.
  707.             RETURN
  708.         ELSE IF (SYMATR(SYMBOL(8,SYMPTR)+5).EQ.0) THEN
  709.             ZYXGAD=.FALSE.
  710.             RETURN
  711.         END IF
  712.         PTR=SYMBOL(8,SYMPTR)+4
  713.         NSUBS=SYMATR(PTR+1)
  714.         ADJP=ZIAND(NSUBS,1024).NE.0
  715.         INFP=ZIAND(NSUBS,2048).NE.0
  716.         NSUBS=MOD(NSUBS,1024)
  717.         DO 100 I=1,NSUBS
  718.             LIMITS(1,I)=SYMATR(PTR+I*2)
  719.             LIMITS(2,I)=SYMATR(PTR+I*2+1)
  720.  100    CONTINUE
  721.         ZYXGAD=.TRUE.
  722.  
  723.         END
  724. C ----------------------------------------------------------------------
  725. C
  726. C       $ S E T _ S F A R G S   -   Set statement function argument list
  727. C
  728.  
  729.         SUBROUTINE ZYXSFA(SYMPTR,NARGS,ADTYPE,ACHLEN)
  730.         INTEGER SYMPTR,NARGS,ADTYPE(NARGS),ACHLEN(NARGS)
  731.  
  732. C---------------------------------------------------------
  733. C    TOOLPACK/1    Release: 2.5
  734. C---------------------------------------------------------
  735.         COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
  736.         INTEGER NSYMS,NPUS,PUIDX(250),
  737.      +          SYMBOL(8,5003)
  738.         LOGICAL MODFLG
  739.  
  740.         SAVE /XCSYMS/
  741. C---------------------------------------------------------
  742. C    TOOLPACK/1    Release: 2.5
  743. C---------------------------------------------------------
  744.         COMMON/XCATRX/SYMATR,ATRGLB
  745.         INTEGER SYMATR(69000),ATRGLB
  746.         SAVE /XCATRX/
  747.  
  748.         INTEGER ATRPTR,I
  749.  
  750.         INTEGER XZYAAB
  751.  
  752.         EXTERNAL ERROR
  753.  
  754.         IF (SYMBOL(8,SYMPTR).NE.0)
  755.      +      CALL ERROR('ZYXSFA: Already set')
  756.         ATRPTR=XZYAAB(1+NARGS*2)
  757.         SYMBOL(8,SYMPTR)=ATRPTR
  758.         SYMATR(ATRPTR)=NARGS
  759.         DO 100 I=1,NARGS
  760.             SYMATR(ATRPTR-1+I*2)=ADTYPE(I)
  761.             SYMATR(ATRPTR+I*2)=ACHLEN(I)
  762.  100    CONTINUE
  763.  
  764.         END
  765. C ----------------------------------------------------------------------
  766. C
  767. C       $ G E T _ S F A R G S   -   Get statement function argument list
  768. C
  769.  
  770.         SUBROUTINE ZYXGFA(SYMPTR,NARGS,ADTYPE,ACHLEN)
  771.         INTEGER SYMPTR,NARGS,ADTYPE(*),ACHLEN(*)
  772.  
  773. C---------------------------------------------------------
  774. C    TOOLPACK/1    Release: 2.5
  775. C---------------------------------------------------------
  776.         COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
  777.         INTEGER NSYMS,NPUS,PUIDX(250),
  778.      +          SYMBOL(8,5003)
  779.         LOGICAL MODFLG
  780.  
  781.         SAVE /XCSYMS/
  782. C---------------------------------------------------------
  783. C    TOOLPACK/1    Release: 2.5
  784. C---------------------------------------------------------
  785.         COMMON/XCATRX/SYMATR,ATRGLB
  786.         INTEGER SYMATR(69000),ATRGLB
  787.         SAVE /XCATRX/
  788.  
  789.         INTEGER ATRPTR,I
  790.  
  791.         EXTERNAL ERROR
  792.  
  793.         IF (SYMBOL(8,SYMPTR).EQ.0)
  794.      +      CALL ERROR('ZYXGFA: No attributes found')
  795.         ATRPTR=SYMBOL(8,SYMPTR)
  796.         NARGS=SYMATR(ATRPTR)
  797.         DO 100 I=1,NARGS
  798.             ADTYPE(I)=SYMATR(ATRPTR-1+I*2)
  799.             ACHLEN(I)=SYMATR(ATRPTR+I*2)
  800.  100    CONTINUE
  801.  
  802.         END
  803. C ----------------------------------------------------------------------
  804. C
  805. C       $ P R O C _ A R G S E T   -   Set/check procedure arguments
  806. C
  807.  
  808.         INTEGER FUNCTION ZYXPAS(NODE,INSF,STMTNO)
  809.         INTEGER NODE,STMTNO
  810.         LOGICAL INSF
  811.  
  812. C---------------------------------------------------------
  813. C    TOOLPACK/1    Release: 2.5
  814. C---------------------------------------------------------
  815.         COMMON/XCATRX/SYMATR,ATRGLB
  816.         INTEGER SYMATR(69000),ATRGLB
  817.         SAVE /XCATRX/
  818. C---------------------------------------------------------
  819. C    TOOLPACK/1    Release: 2.5
  820. C---------------------------------------------------------
  821.         COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
  822.         INTEGER NSYMS,NPUS,PUIDX(250),
  823.      +          SYMBOL(8,5003)
  824.         LOGICAL MODFLG
  825.  
  826.         SAVE /XCSYMS/
  827. C---------------------------------------------------------
  828. C    TOOLPACK/1    Release: 2.5
  829. C---------------------------------------------------------
  830.         COMMON/XCSTRI/STRTXT,STRTBL,NSTRNG,TXTTOP
  831.         INTEGER STRTXT(46339),STRTBL(7103),NSTRNG,TXTTOP
  832.  
  833.         SAVE /XCSTRI/
  834.  
  835.  
  836.         INTEGER MTYPE1
  837.         PARAMETER (MTYPE1=5)
  838.  
  839.         INTEGER SYMPTR,NARGS,ABSIZE,PTR,ATRPTR,BASTYP,NT,XPTR,ARGNUM,
  840.      +          DTYPE,ARGPTR,DCHLEN,ARGN,ARGSYM,ASTACK(160),
  841.      +          TMP(3),I,DUPNUM,P,COUNT,MODSYL(4),MODSYU(4)
  842.         LOGICAL CHECK,FORMAL,EXPR,INCOM,SFARG,DUPARG,ADDIT
  843.  
  844.         INTEGER XZYAAB,XZYTPC
  845.         LOGICAL ZYXVOL
  846.  
  847.         INTEGER ZIAND,ZIOR,EQUAL,LLCRHE,LLCRED,LLFIRS,LLNEXT
  848.         EXTERNAL ZIAND,ZIOR,EQUAL,LLCRHE,LLCRED,LLFIRS,LLNEXT,LLINTO,
  849.      +           ERROR
  850.  
  851.         LOGICAL PROCP,ARRAYP
  852.  
  853. C---------------------------------------------------------
  854. C    TOOLPACK/1    Release: 2.5
  855. C---------------------------------------------------------
  856. C
  857. C Common block and access functions for YP parse tree
  858. C
  859. C---------------------------------------------------------
  860. C    TOOLPACK/1    Release: 2.5
  861. C---------------------------------------------------------
  862.         COMMON/XCTREE/ROOT,TREE,TRETOP
  863.         INTEGER ROOT,TREE(4,46339),TRETOP
  864.  
  865.         SAVE /XCTREE/
  866. C Use "JABC12" to try to avoid conflicts with ordinary variables
  867.         INTEGER NEXT,PREV,UP,DOWN,NATTR,NTYPE,JABC12
  868.  
  869.         NEXT(JABC12)=MOD(TREE(3,JABC12),46340)
  870.         PREV(JABC12)=(TREE(3,JABC12)/46340)
  871.         UP(JABC12)=(TREE(1,JABC12)/46340)
  872.         DOWN(JABC12)=TREE(2,JABC12)
  873.         NTYPE(JABC12)=MOD(TREE(1,JABC12),46340)
  874.         NATTR(JABC12)=TREE(4,JABC12)
  875.  
  876.         PROCP(ARGN)=ZIAND(TREE(4,ARGN),8388608).NE.0
  877.         ARRAYP(ARGN)=ZIAND(TREE(4,ARGN),4194304).NE.0
  878.  
  879.         DATA MODSYU/77,79,68,129/,MODSYL/109,111,100,129/
  880.  
  881. C Note that this routine is called for all external subprogram
  882. C references, and so sets the "extern_arg" bit (which says that
  883. C something is used as an actual argument (and so may be "defined")
  884. C to an external subprogram -- this is to distinguish such usage
  885. C from intrinsic function arguments (because intrinsic functions
  886. C NEVER define their arguments).
  887.  
  888.         ZYXPAS=-1
  889.         PTR=DOWN(NODE)
  890.         IF (NTYPE(PTR).EQ.115) PTR=NEXT(PTR)
  891.         SYMPTR=-DOWN(PTR)
  892.         PTR=NEXT(PTR)
  893.         NARGS=0
  894.         ABSIZE=2
  895.  
  896.  100    IF (PTR.NE.0) THEN
  897.             NARGS=NARGS+1
  898.             IF (TREE(4,PTR)/67108864.EQ.6) THEN
  899.                 ABSIZE=ABSIZE+4
  900.             ELSE
  901.                 ABSIZE=ABSIZE+2
  902.             END IF
  903.             PTR=NEXT(PTR)
  904.             GOTO 100
  905.         END IF
  906.  
  907.         CHECK=SYMBOL(7,SYMPTR).NE.0
  908.         IF (CHECK) THEN
  909.             ATRPTR=SYMBOL(7,SYMPTR)
  910.             IF (SYMATR(ATRPTR+1).NE.NARGS) RETURN
  911.         ELSE
  912.             ATRPTR=XZYAAB(ABSIZE)
  913.             SYMBOL(7,SYMPTR)=ATRPTR
  914.             SYMATR(ATRPTR+1)=NARGS
  915.         END IF
  916.         PTR=DOWN(NODE)
  917.         IF (NTYPE(PTR).EQ.115) PTR=NEXT(PTR)
  918.         PTR=NEXT(PTR)
  919.         ARGPTR=ATRPTR+2
  920.         ARGNUM=0
  921.  
  922.  200    IF (PTR.NE.0) THEN
  923.             ARGNUM=ARGNUM+1
  924.             IF (ARGNUM.GT.160)
  925.      +          CALL ERROR('Too many arguments in external reference')
  926.             DTYPE=TREE(4,PTR)/67108864
  927.             EXPR=.FALSE.
  928.             SFARG=.FALSE.
  929.             DUPARG=.FALSE.
  930.             IF (PROCP(PTR)) THEN
  931.                 BASTYP=3
  932.                 ARGSYM=-DOWN(PTR)
  933. C If procedure, get its data-type from the symbol, not the tree
  934.                 DTYPE=SYMBOL(4,ARGSYM)
  935. C ... if supposedly "generic" intrinsic, must actually by specific
  936.                 IF (DTYPE.EQ.8) THEN
  937.                     IF (EQUAL(STRTXT(SYMBOL(2,ARGSYM)),
  938.      +                        MODSYL).EQ.-2 .OR.
  939.      +                  EQUAL(STRTXT(SYMBOL(2,ARGSYM)),
  940.      +                        MODSYU).EQ.-2) THEN
  941.                         DTYPE = 1
  942.                     ELSE
  943. C ... all "generic" intrinsics are of type real when the name
  944. C     is passed as a parameter.
  945.                         DTYPE = 2
  946.                     END IF
  947.                 END IF
  948.                 ASTACK(ARGNUM)=-ARGNUM
  949.             ELSE IF (ARRAYP(PTR)) THEN
  950.                 BASTYP=2
  951.                 ARGSYM=-DOWN(PTR)
  952. C Set extern_arg bit for array actual argument
  953.                 SYMBOL(6,ARGSYM)=
  954.      +              ZIOR(SYMBOL(6,ARGSYM),131072)
  955.                 ASTACK(ARGNUM)=ARGSYM
  956.             ELSE IF (DTYPE.EQ.10) THEN
  957.                 BASTYP=4
  958.                 ASTACK(ARGNUM)=-ARGNUM
  959.             ELSE
  960.                 NT=NTYPE(PTR)
  961.                 IF (NT.EQ.108) THEN
  962.                     BASTYP=0
  963.                     ARGSYM=-DOWN(PTR)
  964. C Set extern_arg bit for variable or parameter actual argument
  965.                     SYMBOL(6,ARGSYM)=
  966.      +                  ZIOR(SYMBOL(6,ARGSYM),131072)
  967.                     IF (SYMBOL(1,ARGSYM).EQ.6) THEN
  968.                         EXPR=.TRUE.
  969.                         ASTACK(ARGNUM)=-ARGNUM
  970.                     ELSE
  971.                         ASTACK(ARGNUM)=ARGSYM
  972.                     END IF
  973.                 ELSE IF (NT.EQ.104) THEN
  974.                     BASTYP=1
  975.                     ARGSYM=-DOWN(DOWN(PTR))
  976. C Set extern_arg bit for array element actual argument
  977.                     SYMBOL(6,ARGSYM)=
  978.      +                  ZIOR(SYMBOL(6,ARGSYM),131072)
  979.                     ASTACK(ARGNUM)=ARGSYM
  980.                 ELSE IF (NT.EQ.103) THEN
  981.                     IF (NTYPE(DOWN(PTR)).EQ.104) THEN
  982.                         BASTYP=1
  983.                         ARGSYM=-DOWN(DOWN(DOWN(PTR)))
  984. C Set extern_arg bit for array element substring actual argument
  985.                         SYMBOL(6,ARGSYM)=
  986.      +                      ZIOR(SYMBOL(6,ARGSYM),131072)
  987.                         ASTACK(ARGNUM)=ARGSYM
  988.                     ELSE
  989.                         BASTYP=0
  990.                         ARGSYM=-DOWN(DOWN(PTR))
  991. C Set extern_arg bit for substring actual argument
  992.                         SYMBOL(6,ARGSYM)=
  993.      +                      ZIOR(SYMBOL(6,ARGSYM),131072)
  994.                         ASTACK(ARGNUM)=ARGSYM
  995.                     END IF
  996.                 ELSE
  997.                     BASTYP=0
  998.                     EXPR=.TRUE.
  999.                     ASTACK(ARGNUM)=-ARGNUM
  1000.                 END IF
  1001.             END IF
  1002.             IF (BASTYP.EQ.0 .AND. INSF) THEN
  1003. C Must check to see if this occurs in argument list
  1004.                 XPTR=NODE
  1005.  300            XPTR=UP(XPTR)
  1006.                 IF (NTYPE(XPTR).NE.121) GOTO 300
  1007.                 XPTR=DOWN(NEXT(DOWN(XPTR)))
  1008.  400            IF (-DOWN(XPTR).NE.ARGSYM) THEN
  1009.                     XPTR=NEXT(XPTR)
  1010.                     IF (XPTR.GT.0) GOTO 400
  1011.                 ELSE
  1012.                     SFARG=.TRUE.
  1013.                 END IF
  1014.             END IF
  1015.             IF (CHECK) THEN
  1016.                 BASTYP=XZYTPC(BASTYP,
  1017.      +                             MOD(SYMATR(ARGPTR+0),8))
  1018.                 IF (BASTYP.EQ.-1) RETURN
  1019.                 IF (DTYPE.NE.SYMATR(ARGPTR+0)/8+(-3))
  1020.      +              RETURN
  1021.             END IF
  1022. C Put some things passed directly as arguments onto a list
  1023.             IF (BASTYP.NE.4) THEN
  1024. C ... namely dummy arguments, actual procedure arguments, arguments in
  1025. C     common, expression arguments, statement function dummies, and
  1026. C     duplicated actuals.
  1027.                 IF (EXPR .OR. SFARG) THEN
  1028.                     FORMAL=.FALSE.
  1029.                     INCOM=.FALSE.
  1030.                 ELSE
  1031.                     FORMAL=ZIAND(SYMBOL(6,ARGSYM),4)
  1032.      +                     .NE.0
  1033.                     INCOM=ZIAND(SYMBOL(6,ARGSYM),
  1034.      +                          1024+524288).NE.0
  1035. C Check for duplication (except when expr/stmt fn dummy/procedure)
  1036.                     IF (BASTYP.NE.3) THEN
  1037.                         DO 500 I=1,ARGNUM-1
  1038.                             IF (ZYXVOL(ASTACK(I),ARGSYM)) THEN
  1039.                                 DUPARG=.TRUE.
  1040.                                 DUPNUM=I
  1041.                             END IF
  1042.  500                    CONTINUE
  1043.                     END IF
  1044.                 END IF
  1045.                 IF (DUPARG) THEN
  1046. C ... Duplicated arguments may overlap with formals, so do them first
  1047.                     IF (SYMATR(ARGPTR+1).EQ.0)
  1048.      +                  SYMATR(ARGPTR+1)=LLCRHE(SYMATR,0)
  1049.                     TMP(1)=2
  1050.                     TMP(2)=DUPNUM
  1051.                     TMP(3)=STMTNO
  1052.                     CALL LLINTO(SYMATR,LLCRED(SYMATR,3,TMP),
  1053.      +                          SYMATR(ARGPTR+1))
  1054.                 END IF
  1055.                 IF (EXPR .OR. FORMAL .OR. INCOM .OR. SFARG .OR.
  1056.      +              BASTYP.EQ.3) THEN
  1057. C ... create the list first if it hasn't been yet
  1058.                     IF (SYMATR(ARGPTR+1).EQ.0)
  1059.      +                  SYMATR(ARGPTR+1)=LLCRHE(SYMATR,0)
  1060.                     IF (FORMAL) THEN
  1061.                         TMP(1)=6
  1062.                         TMP(2)=ARGSYM
  1063.                     ELSE IF (EXPR) THEN
  1064.                         TMP(1)=1
  1065.                         TMP(2)=0
  1066.                     ELSE IF (INCOM) THEN
  1067.                         TMP(1)=3
  1068.                         TMP(2)=SYMATR(SYMBOL(8,ARGSYM)+1)
  1069.                     ELSE IF (SFARG) THEN
  1070.                         TMP(1)=4
  1071.                         TMP(2)=0
  1072.                     ELSE
  1073.                         TMP(1)=0
  1074.                         TMP(2)=ARGSYM
  1075.                     END IF
  1076.                     TMP(3)=STMTNO
  1077. C For expr: only add it if less than max (MTYPE1)
  1078.                     IF (TMP(1).EQ.1) THEN
  1079.                         COUNT=0
  1080.                         P=LLFIRS(SYMATR,SYMATR(ARGPTR+1))
  1081.                         IF (P.NE.0) THEN
  1082.  600                        IF (SYMATR(P).EQ.1)
  1083.      +                          COUNT=COUNT+1
  1084.                             P=LLNEXT(SYMATR,P)
  1085.                             IF (P.NE.0) GOTO 600
  1086.                         END IF
  1087.                         ADDIT=COUNT.LT.MTYPE1
  1088.                     ELSE
  1089.                         ADDIT=.TRUE.
  1090.                     END IF
  1091.                     IF (ADDIT)
  1092.      +                  CALL LLINTO(SYMATR,LLCRED(SYMATR,3,TMP),
  1093.      +                          SYMATR(ARGPTR+1))
  1094.                 END IF
  1095.             END IF
  1096.             SYMATR(ARGPTR+0)=(DTYPE-(-3))*8+BASTYP
  1097.             IF (DTYPE.EQ.6) THEN
  1098.                 DCHLEN=SYMATR(MOD(TREE(4,PTR),262144))
  1099.                 IF (CHECK) THEN
  1100.                     IF (DCHLEN.LT.SYMATR(ARGPTR+2))
  1101.      +                  SYMATR(ARGPTR+2)=DCHLEN
  1102.                     IF (DCHLEN.GT.SYMATR(ARGPTR+3))
  1103.      +                  SYMATR(ARGPTR+3)=DCHLEN
  1104.                 ELSE
  1105.                     SYMATR(ARGPTR+2)=DCHLEN
  1106.                     SYMATR(ARGPTR+3)=DCHLEN
  1107.                 END IF
  1108.                 ARGPTR=ARGPTR+4
  1109.             ELSE
  1110.                 ARGPTR=ARGPTR+2
  1111.             END IF
  1112.             PTR=NEXT(PTR)
  1113.             GOTO 200
  1114.         END IF
  1115.         ZYXPAS=-2
  1116.  
  1117.         END
  1118. C ----------------------------------------------------------------------
  1119. C
  1120. C       $ S E T U _ D O I R E F   -   Set unsafe do index reference
  1121. C
  1122.  
  1123.         SUBROUTINE ZYXSUD(SYMPTR,ARGNUM,STMTNO)
  1124.         INTEGER SYMPTR,ARGNUM,STMTNO
  1125.  
  1126. C---------------------------------------------------------
  1127. C    TOOLPACK/1    Release: 2.5
  1128. C---------------------------------------------------------
  1129.         COMMON/XCATRX/SYMATR,ATRGLB
  1130.         INTEGER SYMATR(69000),ATRGLB
  1131.         SAVE /XCATRX/
  1132. C---------------------------------------------------------
  1133. C    TOOLPACK/1    Release: 2.5
  1134. C---------------------------------------------------------
  1135.         COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
  1136.         INTEGER NSYMS,NPUS,PUIDX(250),
  1137.      +          SYMBOL(8,5003)
  1138.         LOGICAL MODFLG
  1139.  
  1140.         SAVE /XCSYMS/
  1141.  
  1142.         INTEGER ARGPTR,I,TMP(3)
  1143.  
  1144.         INTEGER LLCRED,LLCRHE
  1145.         EXTERNAL LLCRED,LLCRHE,LLINTO
  1146.  
  1147.         ARGPTR=SYMBOL(7,SYMPTR)+2
  1148.         DO 100 I=1,ARGNUM-1
  1149.             IF (SYMATR(ARGPTR)/8+(-3).EQ.6) THEN
  1150.                 ARGPTR=ARGPTR+4
  1151.             ELSE
  1152.                 ARGPTR=ARGPTR+2
  1153.             END IF
  1154.  100    CONTINUE
  1155.         IF (SYMATR(ARGPTR+1).EQ.0)
  1156.      +      SYMATR(ARGPTR+1)=LLCRHE(SYMATR,0)
  1157.         TMP(1)=5
  1158.         TMP(2)=0
  1159.         TMP(3)=STMTNO
  1160.         CALL LLINTO(SYMATR,LLCRED(SYMATR,3,TMP),SYMATR(ARGPTR+1))
  1161.  
  1162.         END
  1163. C ----------------------------------------------------------------------
  1164. C
  1165. C       $ S E T _ P U A R G S   -   Set program-unit argument list
  1166. C
  1167.  
  1168.         SUBROUTINE ZYXSPA(SYMPTR,NARGS,ARGLST)
  1169.         INTEGER SYMPTR,NARGS,ARGLST(*)
  1170.  
  1171. C---------------------------------------------------------
  1172. C    TOOLPACK/1    Release: 2.5
  1173. C---------------------------------------------------------
  1174.         COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
  1175.         INTEGER NSYMS,NPUS,PUIDX(250),
  1176.      +          SYMBOL(8,5003)
  1177.         LOGICAL MODFLG
  1178.  
  1179.         SAVE /XCSYMS/
  1180. C---------------------------------------------------------
  1181. C    TOOLPACK/1    Release: 2.5
  1182. C---------------------------------------------------------
  1183.         COMMON/XCATRX/SYMATR,ATRGLB
  1184.         INTEGER SYMATR(69000),ATRGLB
  1185.         SAVE /XCATRX/
  1186.  
  1187.         COMMON/EQLC/EQLHDR
  1188.         INTEGER EQLHDR
  1189.  
  1190.         INTEGER ATRPTR,I
  1191.  
  1192.         SAVE /EQLC/
  1193.  
  1194.         INTEGER XZYAAB
  1195.  
  1196.         EXTERNAL ERROR
  1197.  
  1198.         IF (SYMBOL(8,SYMPTR).NE.0)
  1199.      +      CALL ERROR('ZYXSPA: Argument list already set')
  1200.         SYMBOL(7,SYMPTR)=NARGS
  1201.         ATRPTR=XZYAAB(NARGS+2)
  1202.         SYMBOL(8,SYMPTR)=ATRPTR
  1203.         EQLHDR=ATRPTR+NARGS
  1204. C SYMATR(ATRPTR+NARGS+1)=^global pu block (filled in by $ADDG_PU).
  1205.         IF (NARGS.GT.0) THEN
  1206.             DO 100 I=1,NARGS
  1207.                 SYMATR(ATRPTR+I-1)=ARGLST(I)
  1208.  100        CONTINUE
  1209.         END IF
  1210.  
  1211.         END
  1212. C ----------------------------------------------------------------------
  1213. C
  1214. C       $ S C A N _ C O M   -   Pass2: Scan a common block list
  1215. C                                      and fill in all the extra bits
  1216. C
  1217.  
  1218.         INTEGER FUNCTION ZYXSCM(COMPTR,MAIN)
  1219.         INTEGER COMPTR
  1220.         LOGICAL MAIN
  1221.  
  1222. C---------------------------------------------------------
  1223. C    TOOLPACK/1    Release: 2.5
  1224. C---------------------------------------------------------
  1225.         COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
  1226.         INTEGER NSYMS,NPUS,PUIDX(250),
  1227.      +          SYMBOL(8,5003)
  1228.         LOGICAL MODFLG
  1229.  
  1230.         SAVE /XCSYMS/
  1231. C---------------------------------------------------------
  1232. C    TOOLPACK/1    Release: 2.5
  1233. C---------------------------------------------------------
  1234.         COMMON/XCATRX/SYMATR,ATRGLB
  1235.         INTEGER SYMATR(69000),ATRGLB
  1236.         SAVE /XCATRX/
  1237.  
  1238.         INTEGER SPTR,SIZE,VPTR,HEAD
  1239.         LOGICAL SAVED
  1240.  
  1241.         INTEGER LLFIRS,LLNEXT,ZIOR,ZIAND
  1242.         EXTERNAL LLFIRS,LLNEXT,ZIOR,ZIAND,REMARK
  1243.  
  1244.         HEAD=SYMBOL(7,COMPTR)
  1245.         SYMATR(HEAD)=0
  1246.         SPTR=LLFIRS(SYMATR,HEAD)
  1247.         SAVED=SYMBOL(8,COMPTR).EQ.3
  1248.         SIZE=0
  1249.  
  1250.  100    VPTR=SYMATR(SPTR)
  1251.         IF (SYMBOL(8,VPTR).EQ.0) THEN
  1252.             CALL REMARK('ZYXSCM: NO EXTENDED ATTRIBUTE FOR ITEM')
  1253.             ZYXSCM=-67
  1254.             RETURN
  1255.         END IF
  1256.         IF (SIZE.EQ.0) THEN
  1257. C For first item in common, set the common-type
  1258.             IF (SYMBOL(4,VPTR).EQ.6) THEN
  1259.                 SYMBOL(8,COMPTR)=0
  1260.             ELSE
  1261.                 SYMBOL(8,COMPTR)=1
  1262.             END IF
  1263.         ELSE
  1264. C For successive items in common, adjust the common-type
  1265.             IF (SYMBOL(4,VPTR).EQ.6 .AND.
  1266.      +          SYMBOL(8,COMPTR).EQ.1 .OR.
  1267.      +          SYMBOL(4,VPTR).NE.6 .AND.
  1268.      +          SYMBOL(8,COMPTR).EQ.0)
  1269.      +          SYMBOL(8,COMPTR)=2
  1270.         END IF
  1271. C Accumulate the size of the common ...
  1272.         IF (SYMATR(SYMBOL(8,VPTR)).GT.0) THEN
  1273. C ...(a) in each variable's extended data (common-position)
  1274.             SYMATR(SYMBOL(8,VPTR)+2)=SIZE
  1275. C ...(b) for the total
  1276.             SIZE=SIZE+SYMATR(SYMBOL(8,VPTR))
  1277.         ELSE
  1278.             CALL REMARK('ZYXSCM: COMMON TOO COMPLICATED')
  1279.             ZYXSCM=-67
  1280.             RETURN
  1281.         END IF
  1282. C Accumulate all usage bits (inclusive or)
  1283.         SYMATR(HEAD)=ZIOR(SYMATR(HEAD),SYMBOL(6,VPTR))
  1284.         SPTR=LLNEXT(SYMATR,SPTR)
  1285.         IF (SPTR.NE.0) GOTO 100
  1286.  
  1287.         SYMBOL(6,COMPTR)=SIZE
  1288.         IF (MAIN) THEN
  1289.             SYMBOL(8,COMPTR)=SYMBOL(8,COMPTR)+6
  1290.         ELSE IF (SAVED) THEN
  1291.             SYMBOL(8,COMPTR)=SYMBOL(8,COMPTR)+3
  1292.         END IF
  1293.         IF (ZIAND(SYMATR(HEAD),16+32+64+
  1294.      +                         2048+128+16384+
  1295.      +                         512+65536).EQ.0) THEN
  1296.             ZYXSCM=-68
  1297.         ELSE
  1298.             ZYXSCM=-2
  1299.         END IF
  1300.  
  1301.         END
  1302. C ----------------------------------------------------------------------
  1303. C
  1304. C       $ S E T _ S U N I T S   -   Set storage units
  1305. C
  1306.  
  1307.         SUBROUTINE ZYXSSU(SYMPTR)
  1308.         INTEGER SYMPTR
  1309.  
  1310. C---------------------------------------------------------
  1311. C    TOOLPACK/1    Release: 2.5
  1312. C---------------------------------------------------------
  1313.         COMMON/XCTREE/ROOT,TREE,TRETOP
  1314.         INTEGER ROOT,TREE(4,46339),TRETOP
  1315.  
  1316.         SAVE /XCTREE/
  1317. C---------------------------------------------------------
  1318. C    TOOLPACK/1    Release: 2.5
  1319. C---------------------------------------------------------
  1320.         COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
  1321.         INTEGER NSYMS,NPUS,PUIDX(250),
  1322.      +          SYMBOL(8,5003)
  1323.         LOGICAL MODFLG
  1324.  
  1325.         SAVE /XCSYMS/
  1326. C---------------------------------------------------------
  1327. C    TOOLPACK/1    Release: 2.5
  1328. C---------------------------------------------------------
  1329.         COMMON/XCATRX/SYMATR,ATRGLB
  1330.         INTEGER SYMATR(69000),ATRGLB
  1331.         SAVE /XCATRX/
  1332.  
  1333.         INTEGER APTR
  1334.  
  1335.         INTEGER XZYAAB,ZYXGEL,ZYXSU
  1336.  
  1337.         IF (SYMBOL(8,SYMPTR).EQ.0) THEN
  1338.             APTR=XZYAAB(4)
  1339.             SYMBOL(8,SYMPTR)=APTR
  1340.         ELSE
  1341.             APTR=SYMBOL(8,SYMPTR)
  1342.         END IF
  1343.         IF (SYMATR(APTR).NE.0) RETURN
  1344.         IF (SYMBOL(5,SYMPTR).LT.0) THEN
  1345.             SYMATR(APTR)=SYMATR(MOD(TREE(4,-SYMBOL(5,SYMPTR)),
  1346.      +                              262144))
  1347.         ELSE IF (SYMBOL(5,SYMPTR).GT.0) THEN
  1348.             SYMATR(APTR)=SYMBOL(5,SYMPTR)
  1349.         ELSE
  1350.             SYMATR(APTR)=ZYXSU(SYMBOL(4,SYMPTR))
  1351.         END IF
  1352.         IF (SYMBOL(7,SYMPTR).NE.0)
  1353.      +      SYMATR(APTR)=SYMATR(APTR)*ZYXGEL(SYMPTR)
  1354.  
  1355.         END
  1356. C ----------------------------------------------------------------------
  1357. C
  1358. C       $ E V A L _ A R E L M   -   Evaluate array_element_name
  1359. C
  1360.  
  1361.         INTEGER FUNCTION ZYXEAE(NODE)
  1362.         INTEGER NODE
  1363.  
  1364. C---------------------------------------------------------
  1365. C    TOOLPACK/1    Release: 2.5
  1366. C---------------------------------------------------------
  1367.         COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
  1368.         INTEGER NSYMS,NPUS,PUIDX(250),
  1369.      +          SYMBOL(8,5003)
  1370.         LOGICAL MODFLG
  1371.  
  1372.         SAVE /XCSYMS/
  1373. C---------------------------------------------------------
  1374. C    TOOLPACK/1    Release: 2.5
  1375. C---------------------------------------------------------
  1376.         COMMON/XCATRX/SYMATR,ATRGLB
  1377.         INTEGER SYMATR(69000),ATRGLB
  1378.         SAVE /XCATRX/
  1379.  
  1380.         INTEGER PTR,SPTR,MULT,LOW,HIGH,APTR
  1381.  
  1382. C---------------------------------------------------------
  1383. C    TOOLPACK/1    Release: 2.5
  1384. C---------------------------------------------------------
  1385. C
  1386. C Common block and access functions for YP parse tree
  1387. C
  1388. C---------------------------------------------------------
  1389. C    TOOLPACK/1    Release: 2.5
  1390. C---------------------------------------------------------
  1391.         COMMON/XCTREE/ROOT,TREE,TRETOP
  1392.         INTEGER ROOT,TREE(4,46339),TRETOP
  1393.  
  1394.         SAVE /XCTREE/
  1395. C Use "JABC12" to try to avoid conflicts with ordinary variables
  1396.         INTEGER NEXT,PREV,UP,DOWN,NATTR,NTYPE,JABC12
  1397.  
  1398.         NEXT(JABC12)=MOD(TREE(3,JABC12),46340)
  1399.         PREV(JABC12)=(TREE(3,JABC12)/46340)
  1400.         UP(JABC12)=(TREE(1,JABC12)/46340)
  1401.         DOWN(JABC12)=TREE(2,JABC12)
  1402.         NTYPE(JABC12)=MOD(TREE(1,JABC12),46340)
  1403.         NATTR(JABC12)=TREE(4,JABC12)
  1404.  
  1405.         PTR=DOWN(NODE)
  1406.         SPTR=-DOWN(PTR)
  1407.         PTR=NEXT(PTR)
  1408.         APTR=SYMBOL(8,SPTR)+4
  1409.         IF (SYMATR(APTR+0).LT.1) THEN
  1410.             ZYXEAE=-1
  1411.             RETURN
  1412.         END IF
  1413.         ZYXEAE=0
  1414.         MULT=1
  1415.  
  1416.  100    APTR=APTR+2
  1417.         LOW=SYMATR(APTR)
  1418.         HIGH=SYMATR(APTR+1)
  1419.         ZYXEAE=ZYXEAE+
  1420.      +              MULT*(SYMATR(MOD(TREE(4,PTR),262144))-LOW)
  1421.         MULT=MULT*(HIGH-LOW+1)
  1422.         PTR=NEXT(PTR)
  1423.         IF (PTR.NE.0) GOTO 100
  1424.  
  1425.         END
  1426. C ----------------------------------------------------------------------
  1427. C
  1428. C       $ E Q U I V A L E N C E   -   Setup an equivalence relationship
  1429. C
  1430. C       In the following, once the variables have been loaded, these
  1431. C       conditions hold:
  1432. C           after SUDIF=...
  1433. C               loc(SYM1P)+SUDIF = loc(SYM2P)   (I)
  1434. C           after X$EQLIST_END(SYM1,SUDIF1)
  1435. C               loc(SYM1) = SUDIF1+loc(SYM1P)   (II)
  1436. C           after X$EQLIST_TOP(SYM2,SUDIF2)
  1437. C               loc(SYM2) = SUDIF2+loc(SYM2P)   (III)
  1438. C
  1439. C       From these conditions we get:
  1440. C           (a) loc(SYM1)+SUDIF-SUDIF1 = loc(SYM2P)        (by I,II)
  1441. C           (b) loc(SYM1P)+SUDIF+SUDIF2 = loc(SYM2)        (by I,III)
  1442. C           (c) loc(SYM1)+SUDIF-SUDIF1+SUDIF2 = loc(SYM2)  (by I,II,III)
  1443. C
  1444. C       From these results we can derive the storage offsets actually
  1445. C       stored in the equivalence lists.
  1446. C
  1447.  
  1448.         INTEGER FUNCTION ZYXEQV(SYM1P,SUN1,SYM2P,SUN2)
  1449.         INTEGER SYM1P,SUN1,SYM2P,SUN2
  1450.  
  1451. C---------------------------------------------------------
  1452. C    TOOLPACK/1    Release: 2.5
  1453. C---------------------------------------------------------
  1454.         COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
  1455.         INTEGER NSYMS,NPUS,PUIDX(250),
  1456.      +          SYMBOL(8,5003)
  1457.         LOGICAL MODFLG
  1458.  
  1459.         SAVE /XCSYMS/
  1460. C---------------------------------------------------------
  1461. C    TOOLPACK/1    Release: 2.5
  1462. C---------------------------------------------------------
  1463.         COMMON/XCATRX/SYMATR,ATRGLB
  1464.         INTEGER SYMATR(69000),ATRGLB
  1465.         SAVE /XCATRX/
  1466.  
  1467.         COMMON/EQLC/EQLHDR
  1468.         INTEGER EQLHDR
  1469.  
  1470.         INTEGER SYM1,SYM2,SUDIF,VARX1,VARX2,EQH,EQH2,EQV,EQL,EQV2,
  1471.      +          SUDIF1,SUDIF2
  1472.  
  1473.         SAVE /EQLC/
  1474.  
  1475.         INTEGER ZIAND,LLHEAD,LLPRED,LLCRHE,LLCREL,LLFIRS,LLNEXT
  1476.         EXTERNAL ZIAND,LLFOLL,LLINTO,LLHEAD,LLPRED,LLCRHE,LLCREL,LLFIRS,
  1477.      +           LLNEXT,LLDELE,LLDELH,LLPREC
  1478.  
  1479. C Check: Cannot equivalence formal parameters
  1480.         IF (ZIAND(SYMBOL(6,SYM1P),4).NE.0 .OR.
  1481.      +      ZIAND(SYMBOL(6,SYM2P),4).NE.0) THEN
  1482.             ZYXEQV=-70
  1483.             RETURN
  1484.         END IF
  1485. C If no extended data block for variables, create them
  1486. C If one variable in COMMON and the other local, add COMMON location
  1487. C  information to the local varaiable.
  1488.         IF (SYMBOL(8,SYM1P).EQ.0) THEN
  1489.             CALL ZYXSSU(SYM1P)
  1490.         ELSE IF (SYMATR(SYMBOL(8,SYM1P)+1).GT.0) THEN
  1491.             IF (SYMATR(SYMBOL(8,SYM2P)+1).EQ.0)
  1492.      +          SYMATR(SYMBOL(8,SYM2P)+1)=
  1493.      +          SYMATR(SYMBOL(8,SYM1P)+1)
  1494.         ENDIF
  1495.         IF (SYMBOL(8,SYM2P).EQ.0) THEN
  1496.             CALL ZYXSSU(SYM2P)
  1497.         ELSE IF (SYMATR(SYMBOL(8,SYM2P)+1).GT.0) THEN
  1498.             IF (SYMATR(SYMBOL(8,SYM1P)+1).EQ.0)
  1499.      +          SYMATR(SYMBOL(8,SYM1P)+1)=
  1500.      +          SYMATR(SYMBOL(8,SYM2P)+1)
  1501.         ENDIF
  1502.         SUDIF=SUN1-SUN2
  1503.         SYM1=SYM1P
  1504.         SYM2=SYM2P
  1505.         VARX1=SYMBOL(8,SYM1P)
  1506.         VARX2=SYMBOL(8,SYM2P)
  1507.         IF (SYMATR(VARX1+3).EQ.0) THEN
  1508.             IF (SYMATR(VARX2+3).EQ.0) THEN
  1509. C Neither occurs in a list, so make a list for them
  1510. C ... First create a list head and put it on the end of the list list
  1511.                 EQH=LLCRHE(SYMATR,2)
  1512.                 IF (SYMATR(EQLHDR).EQ.0) SYMATR(EQLHDR)=LLCRHE(SYMATR,0)
  1513.                 EQL=LLCREL(SYMATR,1)
  1514.                 SYMATR(EQL)=EQH
  1515.                 CALL LLINTO(SYMATR,EQL,SYMATR(EQLHDR))
  1516. C ... then create eqv records and link them in
  1517.                 EQV=LLCREL(SYMATR,2)
  1518.                 SYMATR(VARX1+3)=EQV
  1519.                 EQV2=LLCREL(SYMATR,2)
  1520.                 SYMATR(VARX2+3)=EQV2
  1521.                 SYMATR(EQV+1)=SYM1
  1522.                 SYMATR(EQV2+1)=SYM2
  1523.                 SYMATR(EQV+0)=SUDIF
  1524.                 CALL LLINTO(SYMATR,EQV,EQH)
  1525.                 CALL LLINTO(SYMATR,EQV2,EQH)
  1526.             ELSE
  1527. C Var 1 isn't in a list yet - put it at the front of list 2
  1528.                 EQV=LLCREL(SYMATR,2)
  1529.                 SYMATR(VARX1+3)=EQV
  1530.                 SYMATR(EQV+1)=SYM1
  1531.                 CALL XZYEQT(SYM2,SUDIF2)
  1532.                 EQV2=SYMATR(SYMBOL(8,SYM2)+3)
  1533.                 SYMATR(EQV+0)=SUDIF+SUDIF2
  1534.                 CALL LLPREC(SYMATR,EQV,EQV2)
  1535.             END IF
  1536.         ELSE IF (SYMATR(VARX2+3).EQ.0) THEN
  1537. C Var 2 isn't in a list yet - put it at the end of list 1
  1538.             EQV=LLCREL(SYMATR,2)
  1539.             SYMATR(VARX2+3)=EQV
  1540.             SYMATR(EQV+0)=0
  1541.             SYMATR(EQV+1)=SYM2
  1542.             CALL XZYEQE(SYM1,SUDIF1)
  1543.             EQV2=SYMATR(SYMBOL(8,SYM1)+3)
  1544.             SYMATR(EQV2+0)=SUDIF-SUDIF1
  1545.             CALL LLFOLL(SYMATR,EQV,EQV2)
  1546.         ELSE
  1547. C Both are are in lists ... here comes trouble
  1548.             CALL XZYEQT(SYM2,SUDIF2)
  1549.             CALL XZYEQE(SYM1,SUDIF1)
  1550.             IF (LLHEAD(SYMATR,SYMATR(SYMBOL(8,SYM1)+3))
  1551.      +          .EQ.
  1552.      +          LLPRED(SYMATR,SYMATR(SYMBOL(8,SYM2)+3)))
  1553.      +      THEN
  1554. C Equivalence loop - it is bad or just redundant?
  1555.                 SYM2=SYM2P
  1556.                 CALL XZYEQE(SYM2,SUDIF2)
  1557.                 IF (SUDIF.NE.SUDIF1-SUDIF2) THEN
  1558.                     ZYXEQV=-69
  1559.                     RETURN
  1560.                 END IF
  1561.             ELSE
  1562. C Not a loop - join the lists
  1563. C ... Set the s.u. diff between the last of #1 & the first of #2
  1564.                 EQV=SYMATR(SYMBOL(8,SYM1)+3)
  1565.                 SYMATR(EQV+0)=SUDIF-SUDIF1+SUDIF2
  1566. C ... Get the head pointers
  1567.                 EQH=LLHEAD(SYMATR,EQV)
  1568.                 EQH2=LLPRED(SYMATR,
  1569.      +                      SYMATR(SYMBOL(8,SYM2)+3))
  1570. C ... Loop: move first element from #2 to the end of #1
  1571.  100            EQV=LLFIRS(SYMATR,EQH2)
  1572.                 IF (EQV.GT.0) THEN
  1573.                     CALL LLINTO(SYMATR,EQV,EQH)
  1574.                     GOTO 100
  1575.                 END IF
  1576. C ... Find the list list entry for list #2 ... and delete it
  1577.                 EQL=SYMATR(EQLHDR)
  1578.  200            EQL=LLNEXT(SYMATR,EQL)
  1579.                 IF (SYMATR(EQL).NE.EQH2) GOTO 200
  1580.                 CALL LLDELE(SYMATR,EQL)
  1581. C ... Delete list header for #2
  1582.                 CALL LLDELH(SYMATR,EQH2)
  1583.             END IF
  1584.         END IF
  1585.         ZYXEQV=-2
  1586.  
  1587.         END
  1588. C ----------------------------------------------------------------------
  1589. C
  1590. C       X $ E Q L I S T _ E N D   -   Move to the end of an EQUIV list
  1591. C
  1592.  
  1593.         SUBROUTINE XZYEQE(SYM,SUDIF)
  1594.         INTEGER SYM,SUDIF
  1595.  
  1596. C---------------------------------------------------------
  1597. C    TOOLPACK/1    Release: 2.5
  1598. C---------------------------------------------------------
  1599.         COMMON/XCATRX/SYMATR,ATRGLB
  1600.         INTEGER SYMATR(69000),ATRGLB
  1601.         SAVE /XCATRX/
  1602. C---------------------------------------------------------
  1603. C    TOOLPACK/1    Release: 2.5
  1604. C---------------------------------------------------------
  1605.         COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
  1606.         INTEGER NSYMS,NPUS,PUIDX(250),
  1607.      +          SYMBOL(8,5003)
  1608.         LOGICAL MODFLG
  1609.  
  1610.         SAVE /XCSYMS/
  1611.  
  1612.         INTEGER TMP,EQV
  1613.  
  1614.         INTEGER LLNEXT
  1615.         EXTERNAL LLNEXT
  1616.  
  1617.         SUDIF=0
  1618.         EQV=SYMATR(SYMBOL(8,SYM)+3)
  1619.  
  1620.  100    TMP=LLNEXT(SYMATR,EQV)
  1621.         IF (TMP.GT.0) THEN
  1622.             SUDIF=SUDIF+SYMATR(EQV+0)
  1623.             EQV=TMP
  1624.             GOTO 100
  1625.         END IF
  1626.         SYM=SYMATR(EQV+1)
  1627.  
  1628.         END
  1629. C ----------------------------------------------------------------------
  1630. C
  1631. C       X $ E Q L I S T _ T O P   -   Move to the top of an EQUIV list
  1632. C
  1633.  
  1634.         SUBROUTINE XZYEQT(SYM,SUDIF)
  1635.         INTEGER SYM,SUDIF
  1636.  
  1637. C---------------------------------------------------------
  1638. C    TOOLPACK/1    Release: 2.5
  1639. C---------------------------------------------------------
  1640.         COMMON/XCATRX/SYMATR,ATRGLB
  1641.         INTEGER SYMATR(69000),ATRGLB
  1642.         SAVE /XCATRX/
  1643. C---------------------------------------------------------
  1644. C    TOOLPACK/1    Release: 2.5
  1645. C---------------------------------------------------------
  1646.         COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
  1647.         INTEGER NSYMS,NPUS,PUIDX(250),
  1648.      +          SYMBOL(8,5003)
  1649.         LOGICAL MODFLG
  1650.  
  1651.         SAVE /XCSYMS/
  1652.  
  1653.         INTEGER TMP,EQV
  1654.  
  1655.         INTEGER LLPREV
  1656.         EXTERNAL LLPREV
  1657.  
  1658.         SUDIF=0
  1659.         EQV=SYMATR(SYMBOL(8,SYM)+3)
  1660.  
  1661.  100    TMP=LLPREV(SYMATR,EQV)
  1662.         IF (TMP.GT.0) THEN
  1663.             EQV=TMP
  1664.             SUDIF=SUDIF-SYMATR(EQV+0)
  1665.             GOTO 100
  1666.         END IF
  1667.         SYM=SYMATR(EQV+1)
  1668.  
  1669.         END
  1670. C ----------------------------------------------------------------------
  1671. C
  1672. C       $ C H E C K _ E Q U I V S   -   Check Equivalences
  1673. C
  1674. C       Also propagate usage bits into the COMMON header
  1675. C
  1676. C       Also propogate storage allocation information into VARX records
  1677. C
  1678.  
  1679.         SUBROUTINE ZYXCEQ(ERRSYM)
  1680.  
  1681. C---------------------------------------------------------
  1682. C    TOOLPACK/1    Release: 2.5
  1683. C---------------------------------------------------------
  1684.         COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
  1685.         INTEGER NSYMS,NPUS,PUIDX(250),
  1686.      +          SYMBOL(8,5003)
  1687.         LOGICAL MODFLG
  1688.  
  1689.         SAVE /XCSYMS/
  1690. C---------------------------------------------------------
  1691. C    TOOLPACK/1    Release: 2.5
  1692. C---------------------------------------------------------
  1693.         COMMON/XCATRX/SYMATR,ATRGLB
  1694.         INTEGER SYMATR(69000),ATRGLB
  1695.         SAVE /XCATRX/
  1696.  
  1697.         COMMON/EQLC/EQLHDR
  1698.         INTEGER EQLHDR
  1699.  
  1700.         INTEGER COMPTR,MINSU,MAXSU,EQLPTR,EQIPTR,EQV,SUNUM,COMOFF,USAGE,
  1701.      +          EQH,CLASS
  1702.  
  1703.         SAVE /EQLC/
  1704.  
  1705.         INTEGER ZIAND,ZIOR,LLFIRS,LLNEXT
  1706.         EXTERNAL ZIAND,ZIOR,LLFIRS,LLNEXT
  1707.         INTEGER COMSTK,COMUST,COMUSP
  1708.         PARAMETER (COMSTK=20)
  1709.         INTEGER COMUNU(COMSTK)
  1710.  
  1711.         IF (SYMATR(EQLHDR).EQ.0) RETURN
  1712.         EQLPTR=LLFIRS(SYMATR,SYMATR(EQLHDR))
  1713.         CLASS=1
  1714.         COMUST=0
  1715.  
  1716. C ... Processing an equivalence list
  1717.  100    CONTINUE
  1718.         EQH=SYMATR(EQLPTR)
  1719.         EQV=LLFIRS(SYMATR,EQH)
  1720.         COMPTR=0
  1721.         MINSU=1
  1722.         MAXSU=1
  1723.         SUNUM=1
  1724.         USAGE=0
  1725.  
  1726. C ... Processing an item on an equivalence list
  1727.  200    EQIPTR=SYMATR(EQV+1)
  1728.         USAGE=ZIOR(USAGE,SYMBOL(6,EQIPTR))
  1729.         IF (ZIAND(SYMBOL(6,EQIPTR),1024).NE.0) THEN
  1730.             IF (COMPTR.EQ.0) THEN
  1731.                 COMPTR=SYMATR(SYMBOL(8,EQIPTR)+1)
  1732.                 COMOFF=SYMATR(SYMBOL(8,EQIPTR)+2)-SUNUM
  1733.             ELSE
  1734.                 IF (COMPTR.NE.
  1735.      +              SYMATR(SYMBOL(8,EQIPTR)+1)) THEN
  1736.                     CALL ERRSYM('Different COMMONs EQUIVALENCEd - ',
  1737.      +                          COMPTR,-1)
  1738.                 ELSE IF (COMOFF+SUNUM.NE.
  1739.      +                   SYMATR(SYMBOL(8,EQIPTR)+2))
  1740.      +          THEN
  1741.                     CALL ERRSYM('EQUIVALENCE conflicts with COMMON ',
  1742.      +                          COMPTR,-1)
  1743.                 END IF
  1744.             END IF
  1745.         END IF
  1746.         MAXSU=MAX(MAXSU,SUNUM+SYMATR(SYMBOL(8,EQIPTR)))
  1747.         SUNUM=SUNUM+SYMATR(EQV+0)
  1748.         IF (SUNUM.LT.MINSU) MINSU=SUNUM
  1749.  
  1750. C ... process next item on an equivalence list
  1751.         EQV=LLNEXT(SYMATR,EQV)
  1752.         IF (EQV.GT.0) GOTO 200
  1753.  
  1754. C ... processed all items on list - check results
  1755.         SYMATR(EQH+0)=COMPTR
  1756.         SYMATR(EQH+1)=USAGE
  1757.         IF (COMPTR.NE.0) THEN
  1758. C ... EQUIVALENCE involves COMMON - more to do and check
  1759.             SYMATR(SYMBOL(7,COMPTR))=
  1760.      +          ZIOR(SYMATR(SYMBOL(7,COMPTR)),USAGE)
  1761.             IF (ZIAND(SYMATR(SYMBOL(7,COMPTR)),
  1762.      +                16+32+64+2048+
  1763.      +                128+16384+65536).EQ.0) THEN
  1764. C ... COMMON is unused, put on stack and output error if not
  1765. C     already stacked
  1766.                 DO 250 COMUSP=1,COMUST
  1767.                     IF (COMUNU(COMUSP).EQ.COMPTR) GOTO 260
  1768.  250            CONTINUE
  1769.                 IF (COMUST.LT.COMSTK) COMUST=COMUST+1
  1770.                 COMUNU(COMUST)=COMPTR
  1771.                 CALL ERRSYM('Unused common block - ',COMPTR,-1002)
  1772.  260            CONTINUE
  1773.             ENDIF
  1774.             IF (COMOFF+MINSU.LT.0) THEN
  1775.                 CALL ERRSYM('Backward extension of COMMON ',
  1776.      +                      COMPTR,-1)
  1777.             ELSE
  1778. C Check for COMMON being made larger via this EQUIVALENCE
  1779.                 IF (COMOFF+MAXSU.GT.SYMBOL(6,COMPTR))
  1780.      +              SYMBOL(6,COMPTR)=COMOFF+MAXSU
  1781. C ... Run through the equivalence list again, setting the common values
  1782.                 EQV=LLFIRS(SYMATR,EQH)
  1783.                 SUNUM=1
  1784.  300            EQIPTR=SYMATR(EQV+1)
  1785. C ... Mark this variable as being stored in common and say where
  1786.                 SYMBOL(6,EQIPTR)=
  1787.      +              ZIOR(SYMBOL(6,EQIPTR),524288)
  1788.                 SYMATR(SYMBOL(8,EQIPTR)+2)=
  1789.      +              COMOFF+SUNUM
  1790.                 SUNUM=SUNUM+SYMATR(EQV+0)
  1791.                 EQV=LLNEXT(SYMATR,EQV)
  1792.                 IF (EQV.NE.0) GOTO 300
  1793.             END IF
  1794.         ELSE
  1795. C ... Local equivalence class - set storage allocation info in VARX rcd
  1796.             EQV=LLFIRS(SYMATR,EQH)
  1797.             SUNUM=1
  1798.  400        EQIPTR=SYMATR(EQV+1)
  1799.             SYMATR(SYMBOL(8,EQIPTR)+1)=-CLASS
  1800.             SYMATR(SYMBOL(8,EQIPTR)+2)=SUNUM-MINSU
  1801.             SUNUM=SUNUM+SYMATR(EQV+0)
  1802.             EQV=LLNEXT(SYMATR,EQV)
  1803.             IF (EQV.NE.0) GOTO 400
  1804.             CLASS=CLASS+1
  1805.         END IF
  1806.  
  1807. C ... process next equivalence list
  1808.         EQLPTR=LLNEXT(SYMATR,EQLPTR)
  1809.         IF (EQLPTR.GT.0) GOTO 100
  1810.  
  1811.         END
  1812. C ----------------------------------------------------------------------
  1813. C
  1814. C       $ G E T _ L O C A T I O N   -   Return storage allocation info
  1815. C
  1816.  
  1817.         SUBROUTINE ZYXGVL(VARPTR,PLACE,OFFSET)
  1818.         INTEGER VARPTR,PLACE,OFFSET
  1819.  
  1820. C---------------------------------------------------------
  1821. C    TOOLPACK/1    Release: 2.5
  1822. C---------------------------------------------------------
  1823.         COMMON/XCATRX/SYMATR,ATRGLB
  1824.         INTEGER SYMATR(69000),ATRGLB
  1825.         SAVE /XCATRX/
  1826. C---------------------------------------------------------
  1827. C    TOOLPACK/1    Release: 2.5
  1828. C---------------------------------------------------------
  1829.         COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
  1830.         INTEGER NSYMS,NPUS,PUIDX(250),
  1831.      +          SYMBOL(8,5003)
  1832.         LOGICAL MODFLG
  1833.  
  1834.         SAVE /XCSYMS/
  1835.  
  1836.         PLACE=SYMATR(SYMBOL(8,VARPTR)+1)
  1837.         OFFSET=SYMATR(SYMBOL(8,VARPTR)+2)
  1838.  
  1839.         END
  1840. C ----------------------------------------------------------------------
  1841. C
  1842. C       $ G E T _ E Q L I S T   -   Get an equivalence list header
  1843. C
  1844.  
  1845.         SUBROUTINE ZYXGEQ(PUSYM,EQLIST,EQHCOM,EQHUSE,EQVPTR)
  1846.         INTEGER PUSYM,EQLIST,EQHCOM,EQHUSE,EQVPTR
  1847.  
  1848. C---------------------------------------------------------
  1849. C    TOOLPACK/1    Release: 2.5
  1850. C---------------------------------------------------------
  1851.         COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
  1852.         INTEGER NSYMS,NPUS,PUIDX(250),
  1853.      +          SYMBOL(8,5003)
  1854.         LOGICAL MODFLG
  1855.  
  1856.         SAVE /XCSYMS/
  1857. C---------------------------------------------------------
  1858. C    TOOLPACK/1    Release: 2.5
  1859. C---------------------------------------------------------
  1860.         COMMON/XCATRX/SYMATR,ATRGLB
  1861.         INTEGER SYMATR(69000),ATRGLB
  1862.         SAVE /XCATRX/
  1863.  
  1864.         INTEGER LLNEXT,LLFIRS
  1865.         EXTERNAL LLNEXT,LLFIRS,ERROR
  1866.  
  1867.         IF (EQLIST.EQ.0) THEN
  1868. C If we want the first equivalence list for a program-unit
  1869.             IF (SYMBOL(8,PUSYM).LE.0) THEN
  1870. C Make sure we have an extended data block to get it from
  1871.                 CALL ERROR('ZYXGEQ: No PUX record')
  1872.             ELSE IF (
  1873.      +        SYMATR(SYMBOL(8,PUSYM)+SYMBOL(7,PUSYM)).EQ.0)
  1874.      +      THEN
  1875. C If there are no equivalence lists then say so
  1876.                 EQLIST=-1
  1877.             ELSE
  1878. C Otherwise find the first
  1879.                 EQLIST=LLFIRS(SYMATR,
  1880.      +            SYMATR(SYMBOL(8,PUSYM)+SYMBOL(7,PUSYM)))
  1881.             END IF
  1882.         END IF
  1883.         IF (EQLIST.GT.0) THEN
  1884. C Fetch the data for the current equivalence list
  1885.             EQHCOM=SYMATR(SYMATR(EQLIST)+0)
  1886.             EQHUSE=SYMATR(SYMATR(EQLIST)+1)
  1887.             EQVPTR=LLFIRS(SYMATR,SYMATR(EQLIST))
  1888. C And then advance the eqlist pointer
  1889.             EQLIST=LLNEXT(SYMATR,EQLIST)
  1890.         END IF
  1891.  
  1892.         END
  1893. C ----------------------------------------------------------------------
  1894. C
  1895. C       $ G E T _ E Q V D A T A   -   Get equivalence data
  1896. C
  1897.  
  1898.         SUBROUTINE ZYXGED(EQVPTR,VARPTR,OFFSET)
  1899.         INTEGER EQVPTR,VARPTR,OFFSET
  1900.  
  1901. C---------------------------------------------------------
  1902. C    TOOLPACK/1    Release: 2.5
  1903. C---------------------------------------------------------
  1904.         COMMON/XCATRX/SYMATR,ATRGLB
  1905.         INTEGER SYMATR(69000),ATRGLB
  1906.         SAVE /XCATRX/
  1907.  
  1908.         INTEGER LLNEXT
  1909.         EXTERNAL LLNEXT,ERROR
  1910.  
  1911.         IF (EQVPTR.LE.0) CALL ERROR('ZYXGED: Invalid EQV pointer')
  1912.         VARPTR=SYMATR(EQVPTR+1)
  1913.         OFFSET=SYMATR(EQVPTR+0)
  1914.         EQVPTR=LLNEXT(SYMATR,EQVPTR)
  1915.  
  1916.         END
  1917. C ----------------------------------------------------------------------
  1918. C
  1919. C       $ G E T _ E Q U I V _ H E A D   -   Get equivalence head
  1920. C                                           (return equivalence list
  1921. C                                            data from a var in it).
  1922. C
  1923.  
  1924.         SUBROUTINE ZYXGEH(VARPTR,EQHCOM,EQHUSE,EQVPTR)
  1925.         INTEGER VARPTR,EQHCOM,EQHUSE,EQVPTR
  1926.  
  1927. C---------------------------------------------------------
  1928. C    TOOLPACK/1    Release: 2.5
  1929. C---------------------------------------------------------
  1930.         COMMON/XCATRX/SYMATR,ATRGLB
  1931.         INTEGER SYMATR(69000),ATRGLB
  1932.         SAVE /XCATRX/
  1933. C---------------------------------------------------------
  1934. C    TOOLPACK/1    Release: 2.5
  1935. C---------------------------------------------------------
  1936.         COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
  1937.         INTEGER NSYMS,NPUS,PUIDX(250),
  1938.      +          SYMBOL(8,5003)
  1939.         LOGICAL MODFLG
  1940.  
  1941.         SAVE /XCSYMS/
  1942.  
  1943.         INTEGER EQV,EQH
  1944.  
  1945.         INTEGER LLHEAD,LLFIRS
  1946.         EXTERNAL LLHEAD,LLFIRS,ERROR
  1947.  
  1948. C Get pointer to eqv record
  1949.         EQV=SYMATR(SYMBOL(8,VARPTR)+3)
  1950. C Make sure there is one
  1951.         IF (EQV.EQ.0) CALL ERROR('ZYXGEH: Not in equiv..')
  1952. C Okay, get pointer to owning eqh record
  1953.         EQH=LLHEAD(SYMATR,EQV)
  1954. C Return data from eqh record
  1955.         EQHCOM=SYMATR(EQH+0)
  1956.         EQHUSE=SYMATR(EQH+1)
  1957. C Return pointer to first eqv record in the list
  1958.         EQVPTR=LLFIRS(SYMATR,EQH)
  1959.  
  1960.         END
  1961. C ----------------------------------------------------------------------
  1962. C
  1963. C       $ E Q C L A S S _ S I Z E   -   Return size of an equivalence
  1964. C                                       class, in char storage units
  1965. C
  1966.  
  1967.         INTEGER FUNCTION ZYXECS(PUSYM,CLASS)
  1968.         INTEGER PUSYM,CLASS
  1969.  
  1970. C---------------------------------------------------------
  1971. C    TOOLPACK/1    Release: 2.5
  1972. C---------------------------------------------------------
  1973.         COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
  1974.         INTEGER NSYMS,NPUS,PUIDX(250),
  1975.      +          SYMBOL(8,5003)
  1976.         LOGICAL MODFLG
  1977.  
  1978.         SAVE /XCSYMS/
  1979. C---------------------------------------------------------
  1980. C    TOOLPACK/1    Release: 2.5
  1981. C---------------------------------------------------------
  1982.         COMMON/XCATRX/SYMATR,ATRGLB
  1983.         INTEGER SYMATR(69000),ATRGLB
  1984.         SAVE /XCATRX/
  1985.  
  1986.         INTEGER EQLIST,EQH,COUNT,MINSU,MAXSU,EQV,EQIPTR,SUNUM
  1987.  
  1988.         INTEGER LLFIRS,LLNEXT
  1989.         EXTERNAL LLFIRS,LLNEXT,ERROR
  1990.  
  1991.         IF (SYMBOL(8,PUSYM).LE.0)
  1992.      +      CALL ERROR('ZYXECS: No extended PU block')
  1993.         IF (SYMATR(SYMBOL(8,PUSYM)+SYMBOL(7,PUSYM)).EQ.0)
  1994.      +      CALL ERROR('ZYXECS: No equivalence lists found')
  1995.         EQLIST=LLFIRS(SYMATR,
  1996.      +      SYMATR(SYMBOL(8,PUSYM)+SYMBOL(7,PUSYM)))
  1997.         COUNT=0
  1998.  
  1999.  100    EQH=SYMATR(EQLIST)
  2000.         IF (SYMATR(EQH+0).EQ.0) COUNT=COUNT+1
  2001.         IF (COUNT.LT.CLASS) THEN
  2002.             EQLIST=LLNEXT(SYMATR,EQLIST)
  2003.             IF (EQLIST.NE.0) GOTO 100
  2004.             CALL ERROR('ZYXECS: Invalid class numb'//'er')
  2005.         END IF
  2006.  
  2007.         EQV=LLFIRS(SYMATR,EQH)
  2008.         MINSU=1
  2009.         MAXSU=1
  2010.         SUNUM=1
  2011.  200    EQIPTR=SYMATR(EQV+1)
  2012.         MAXSU=MAX(MAXSU,MINSU+SYMATR(SYMBOL(8,EQIPTR)+0))
  2013.         SUNUM=SUNUM+SYMATR(EQV+0)
  2014.         MINSU=MIN(MINSU,SUNUM)
  2015.         EQV=LLNEXT(SYMATR,EQV)
  2016.         IF (EQV.GT.0) GOTO 200
  2017.  
  2018.         ZYXECS=MAXSU-MINSU
  2019.  
  2020.         END
  2021. C ----------------------------------------------------------------------
  2022. C
  2023. C       $ G E T _ C O M V A R   -   Return first/next variable in COMMON
  2024. C
  2025.  
  2026.         SUBROUTINE ZYXGCV(COMPTR,VARPTR)
  2027.         INTEGER COMPTR,VARPTR
  2028.  
  2029. C---------------------------------------------------------
  2030. C    TOOLPACK/1    Release: 2.5
  2031. C---------------------------------------------------------
  2032.         COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
  2033.         INTEGER NSYMS,NPUS,PUIDX(250),
  2034.      +          SYMBOL(8,5003)
  2035.         LOGICAL MODFLG
  2036.  
  2037.         SAVE /XCSYMS/
  2038. C---------------------------------------------------------
  2039. C    TOOLPACK/1    Release: 2.5
  2040. C---------------------------------------------------------
  2041.         COMMON/XCATRX/SYMATR,ATRGLB
  2042.         INTEGER SYMATR(69000),ATRGLB
  2043.         SAVE /XCATRX/
  2044.  
  2045.         INTEGER LLFIRS,LLNEXT
  2046.         EXTERNAL LLFIRS,LLNEXT
  2047.  
  2048.         IF (COMPTR.GT.0)
  2049.      +      COMPTR=-LLFIRS(SYMATR,SYMBOL(7,COMPTR))
  2050.         VARPTR=SYMATR(-COMPTR)
  2051.         COMPTR=-LLNEXT(SYMATR,-COMPTR)
  2052.  
  2053.         END
  2054. C ----------------------------------------------------------------------
  2055. C
  2056. C       $ G E T _ C O M _ U S E   -   Return common usage
  2057. C
  2058.  
  2059.         INTEGER FUNCTION ZYXCUS(COMPTR)
  2060.         INTEGER COMPTR
  2061.  
  2062. C---------------------------------------------------------
  2063. C    TOOLPACK/1    Release: 2.5
  2064. C---------------------------------------------------------
  2065.         COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
  2066.         INTEGER NSYMS,NPUS,PUIDX(250),
  2067.      +          SYMBOL(8,5003)
  2068.         LOGICAL MODFLG
  2069.  
  2070.         SAVE /XCSYMS/
  2071. C---------------------------------------------------------
  2072. C    TOOLPACK/1    Release: 2.5
  2073. C---------------------------------------------------------
  2074.         COMMON/XCATRX/SYMATR,ATRGLB
  2075.         INTEGER SYMATR(69000),ATRGLB
  2076.         SAVE /XCATRX/
  2077.  
  2078.         ZYXCUS=SYMATR(SYMBOL(7,COMPTR))
  2079.  
  2080.         END
  2081. C ----------------------------------------------------------------------
  2082. C
  2083. C       $ V A R S _ O V E R L A P   -   Whether variables overlap
  2084. C
  2085.  
  2086.         LOGICAL FUNCTION ZYXVOL(VARPT1,VARPT2)
  2087.         INTEGER VARPT1,VARPT2
  2088.  
  2089. C---------------------------------------------------------
  2090. C    TOOLPACK/1    Release: 2.5
  2091. C---------------------------------------------------------
  2092.         COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
  2093.         INTEGER NSYMS,NPUS,PUIDX(250),
  2094.      +          SYMBOL(8,5003)
  2095.         LOGICAL MODFLG
  2096.  
  2097.         SAVE /XCSYMS/
  2098. C---------------------------------------------------------
  2099. C    TOOLPACK/1    Release: 2.5
  2100. C---------------------------------------------------------
  2101.         COMMON/XCATRX/SYMATR,ATRGLB
  2102.         INTEGER SYMATR(69000),ATRGLB
  2103.         SAVE /XCATRX/
  2104.  
  2105.         INTEGER VARX1,VARX2
  2106.  
  2107.         EXTERNAL ERROR
  2108.  
  2109.         IF (VARPT1.EQ.VARPT2) THEN
  2110. C Same variable
  2111.             ZYXVOL=.TRUE.
  2112.         ELSE IF (VARPT1.LT.1 .OR. VARPT2.LT.1) THEN
  2113. C Negative numbers are for expression actual arguments and the like
  2114. C -- strangely enough, these never overlap!
  2115.             ZYXVOL=.FALSE.
  2116.         ELSE IF (SYMBOL(8,VARPT1).EQ.0 .OR.
  2117.      +           SYMBOL(8,VARPT2).EQ.0) THEN
  2118. C No extended data block - cannot happen!
  2119.             CALL ERROR('ZYXVOL: Missing VARX record')
  2120.         ELSE
  2121.             VARX1=SYMBOL(8,VARPT1)
  2122.             VARX2=SYMBOL(8,VARPT2)
  2123.             IF (SYMATR(VARX1+1).EQ.0 .OR.
  2124.      +          SYMATR(VARX1+1).NE.SYMATR(VARX2+1))
  2125.      +      THEN
  2126. C Local non-equivalenced variables cannot overlap, and
  2127. C others must be in the same common block or equivalence class
  2128. C (dummy variables look like unequivalenced locals, so that's ok)
  2129.                 ZYXVOL=.FALSE.
  2130.             ELSE IF (
  2131.      +          SYMATR(VARX1+2)+SYMATR(VARX1+0).LE.
  2132.      +          SYMATR(VARX2+2) .OR.
  2133.      +          SYMATR(VARX2+2)+SYMATR(VARX2+0).LE.
  2134.      +          SYMATR(VARX1+2)) THEN
  2135. C They are in the same place - but they still don't overlap if the top
  2136. C of the first is less than the bottom of the second or vice versa
  2137.                 ZYXVOL=.FALSE.
  2138.             ELSE
  2139. C Nope - they must overlap then
  2140.                 ZYXVOL=.TRUE.
  2141.             END IF
  2142.         END IF
  2143.  
  2144.         END
  2145. C ----------------------------------------------------------------------
  2146. C
  2147. C       $ S U   -   Return storage units per datatype
  2148. C
  2149.  
  2150.         INTEGER FUNCTION ZYXSU(DTYPE)
  2151.         INTEGER DTYPE
  2152.  
  2153.         INTEGER DPSIZE,CMSIZE,DCMSIZ,R16SIZ,I2SIZE,L1SIZE,L2SIZE
  2154.         PARAMETER (DPSIZE=4*2,CMSIZE=DPSIZE,DCMSIZ=CMSIZE*2,
  2155.      +             R16SIZ=4*4,I2SIZE=4/2,
  2156.      +             L1SIZE=4/4,L2SIZE=4/2)
  2157.  
  2158.         INTEGER BSIZE(15)
  2159.  
  2160.         SAVE BSIZE
  2161.  
  2162.         DATA BSIZE(6)/1/,
  2163.      +       BSIZE(1)/4/,
  2164.      +       BSIZE(2)/4/,
  2165.      +       BSIZE(5)/DPSIZE/,
  2166.      +       BSIZE(4)/CMSIZE/,
  2167.      +       BSIZE(3)/4/,
  2168.      +       BSIZE(7)/DCMSIZ/,
  2169.      +       BSIZE(12)/L1SIZE/,
  2170.      +       BSIZE(13)/L2SIZE/,
  2171.      +       BSIZE(14)/I2SIZE/,
  2172.      +       BSIZE(15)/R16SIZ/
  2173.  
  2174.         ZYXSU=BSIZE(DTYPE)
  2175.  
  2176.         END
  2177. C ----------------------------------------------------------------------
  2178. C
  2179. C       $ A D D G _ P U   -   Add global symbol for program unit
  2180. C
  2181.  
  2182.         INTEGER FUNCTION ZYXAPU(SYMPTR)
  2183.         INTEGER SYMPTR
  2184.  
  2185. C---------------------------------------------------------
  2186. C    TOOLPACK/1    Release: 2.5
  2187. C---------------------------------------------------------
  2188.         COMMON/XCSTRI/STRTXT,STRTBL,NSTRNG,TXTTOP
  2189.         INTEGER STRTXT(46339),STRTBL(7103),NSTRNG,TXTTOP
  2190.  
  2191.         SAVE /XCSTRI/
  2192.  
  2193. C---------------------------------------------------------
  2194. C    TOOLPACK/1    Release: 2.5
  2195. C---------------------------------------------------------
  2196.         COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
  2197.         INTEGER NSYMS,NPUS,PUIDX(250),
  2198.      +          SYMBOL(8,5003)
  2199.         LOGICAL MODFLG
  2200.  
  2201.         SAVE /XCSYMS/
  2202. C---------------------------------------------------------
  2203. C    TOOLPACK/1    Release: 2.5
  2204. C---------------------------------------------------------
  2205.         COMMON/XCATRX/SYMATR,ATRGLB
  2206.         INTEGER SYMATR(69000),ATRGLB
  2207.         SAVE /XCATRX/
  2208.  
  2209.         INTEGER NARGS,PUPTR,ARGPTR,I,NAMLEN,PUDATA
  2210.  
  2211.         INTEGER ZYXGVA
  2212.  
  2213.         INTEGER ZIAND,EQUAL,LENGTH,LLCRHE,LLFIRS,LLNEXT,LLCREL,ZYCADT
  2214.         EXTERNAL ZIAND,EQUAL,LENGTH,SCOPY,LLCRHE,LLFIRS,LLNEXT,LLCREL,
  2215.      +           LLINTO,ZYCADT
  2216.  
  2217.         IF (SYMATR(ATRGLB+0).EQ.0)
  2218.      +      SYMATR(ATRGLB+0)=LLCRHE(SYMATR,0)
  2219.         PUPTR=LLFIRS(SYMATR,SYMATR(ATRGLB+0))
  2220.  100    IF (PUPTR.NE.0) THEN
  2221.             IF (EQUAL(STRTXT(SYMBOL(2,SYMPTR)),
  2222.      +                SYMATR(PUPTR)).EQ.-2) THEN
  2223.                 ZYXAPU=-1
  2224.                 RETURN
  2225.             END IF
  2226.             PUPTR=LLNEXT(SYMATR,PUPTR)
  2227.             GOTO 100
  2228.         END IF
  2229.         IF (SYMATR(ATRGLB+3).NE.0)
  2230.      +      PUPTR=LLFIRS(SYMATR,SYMATR(ATRGLB+3))
  2231.  200    IF (PUPTR.NE.0) THEN
  2232.             IF (EQUAL(STRTXT(SYMBOL(2,SYMPTR)),
  2233.      +                SYMATR(PUPTR)).EQ.-2) THEN
  2234.                 ZYXAPU=-1
  2235.                 RETURN
  2236.             END IF
  2237.             PUPTR=LLNEXT(SYMATR,PUPTR)
  2238.             GOTO 200
  2239.         END IF
  2240.         NARGS=SYMBOL(7,SYMPTR)
  2241.         NAMLEN=LENGTH(STRTXT(SYMBOL(2,SYMPTR)))
  2242. C Create the global pu data block & link it to the global pu list
  2243.         PUPTR=LLCREL(SYMATR,NAMLEN+7+NARGS*7)
  2244.         CALL LLINTO(SYMATR,PUPTR,SYMATR(ATRGLB+0))
  2245. C Store a pointer to the global pu block in the local pu block
  2246.         SYMATR(SYMBOL(8,SYMPTR)+NARGS+1)=PUPTR
  2247.         PUDATA=PUPTR+NAMLEN
  2248.         CALL SCOPY(STRTXT,SYMBOL(2,SYMPTR),SYMATR,PUPTR)
  2249. C Store canonicalised data type in global pu block
  2250.         IF (SYMBOL(4,SYMPTR).NE.6) THEN
  2251.             SYMATR(PUDATA+1)=
  2252.      +          ZYCADT(SYMBOL(4,SYMPTR),
  2253.      +                 SYMBOL(5,SYMPTR))
  2254.             SYMATR(PUDATA+2)=0
  2255.         ELSE
  2256.             SYMATR(PUDATA+1)=6
  2257.             IF (SYMBOL(5,SYMPTR).LT.0) THEN
  2258.                 SYMATR(PUDATA+2)=
  2259.      +              ZYXGVA(-SYMBOL(5,SYMPTR))
  2260.             ELSE IF (SYMBOL(5,SYMPTR).GT.0) THEN
  2261.                 SYMATR(PUDATA+2)=SYMBOL(5,SYMPTR)
  2262.             ELSE
  2263.                 SYMATR(PUDATA+2)=1
  2264.             END IF
  2265.         END IF
  2266.         SYMATR(PUDATA+4)=NARGS
  2267.         SYMATR(PUDATA+5)=0
  2268.         SYMATR(PUDATA+3)=0
  2269.         SYMATR(PUDATA+6)=0
  2270.         PUDATA=PUDATA+7
  2271.         DO 400 I=0,NARGS-1
  2272.             ARGPTR=SYMATR(SYMBOL(8,SYMPTR)+I)
  2273.             IF (ARGPTR.LT.1) THEN
  2274. C "label" dummy arguments don't have symbols attached...
  2275.                 SYMATR(PUDATA+0)=10
  2276.                 SYMATR(PUDATA+3)=3
  2277.                 GOTO 300
  2278.             END IF
  2279.             IF (SYMBOL(4,ARGPTR).NE.6) THEN
  2280.                 SYMATR(PUDATA+0)=
  2281.      +              ZYCADT(SYMBOL(4,ARGPTR),
  2282.      +                     SYMBOL(5,ARGPTR))
  2283.                 SYMATR(PUDATA+1)=0
  2284.             ELSE
  2285.                 SYMATR(PUDATA+0)=6
  2286.                 IF (SYMBOL(5,ARGPTR).LT.0) THEN
  2287.                     SYMATR(PUDATA+1)=
  2288.      +                  ZYXGVA(-SYMBOL(5,ARGPTR))
  2289.                 ELSE IF (SYMBOL(5,ARGPTR).EQ.0) THEN
  2290.                     SYMATR(PUDATA+1)=1
  2291.                 ELSE
  2292.                     SYMATR(PUDATA+1)=
  2293.      +                  SYMBOL(5,ARGPTR)
  2294.                 END IF
  2295.             END IF
  2296. C Argument usage
  2297.             IF (ZIAND(SYMBOL(6,ARGPTR),
  2298.      +          16+32+64+65536).EQ.0)
  2299.      +      THEN
  2300.                 IF (ZIAND(SYMBOL(6,ARGPTR),131072).EQ.0)
  2301.      +          THEN
  2302.                     SYMATR(PUDATA+2)=1
  2303.                 ELSE
  2304.                     SYMATR(PUDATA+2)=0
  2305.                 END IF
  2306.             ELSE
  2307.                 SYMATR(PUDATA+2)=2
  2308.             END IF
  2309. C Argument structure
  2310.             IF (SYMBOL(1,ARGPTR).EQ.7) THEN
  2311.                 SYMATR(PUDATA+3)=2
  2312.             ELSE IF (SYMBOL(7,ARGPTR).NE.0) THEN
  2313.                 SYMATR(PUDATA+3)=1
  2314.             ELSE
  2315.                 SYMATR(PUDATA+3)=0
  2316.             END IF
  2317. C Argument size: (only for variables/arrays) (0=inf/adj)
  2318.             IF (SYMBOL(1,ARGPTR).EQ.5) THEN
  2319.                 SYMATR(PUDATA+4)=
  2320.      +              SYMATR(SYMBOL(8,ARGPTR))
  2321.             ELSE
  2322.                 SYMATR(PUDATA+4)=0
  2323.             END IF
  2324.             SYMATR(PUDATA+5)=0
  2325.             SYMATR(PUDATA+6)=0
  2326.  300        PUDATA=PUDATA+7
  2327.  400    CONTINUE
  2328.         ZYXAPU=-2
  2329.  
  2330.         END
  2331. C ----------------------------------------------------------------------
  2332. C
  2333. C       $ A D D G _ E N T R Y   -   Add global symbol for ENTRY point
  2334. C
  2335.  
  2336.         INTEGER FUNCTION ZYXAEN(SYMPTR,PUSYM)
  2337.         INTEGER SYMPTR,PUSYM
  2338.  
  2339. C---------------------------------------------------------
  2340. C    TOOLPACK/1    Release: 2.5
  2341. C---------------------------------------------------------
  2342.         COMMON/XCATRX/SYMATR,ATRGLB
  2343.         INTEGER SYMATR(69000),ATRGLB
  2344.         SAVE /XCATRX/
  2345. C---------------------------------------------------------
  2346. C    TOOLPACK/1    Release: 2.5
  2347. C---------------------------------------------------------
  2348.         COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
  2349.         INTEGER NSYMS,NPUS,PUIDX(250),
  2350.      +          SYMBOL(8,5003)
  2351.         LOGICAL MODFLG
  2352.  
  2353.         SAVE /XCSYMS/
  2354. C---------------------------------------------------------
  2355. C    TOOLPACK/1    Release: 2.5
  2356. C---------------------------------------------------------
  2357.         COMMON/XCSTRI/STRTXT,STRTBL,NSTRNG,TXTTOP
  2358.         INTEGER STRTXT(46339),STRTBL(7103),NSTRNG,TXTTOP
  2359.  
  2360.         SAVE /XCSTRI/
  2361.  
  2362.  
  2363.         INTEGER PTR,PUGLOB,NAMLEN,PTR2,PTR3,I,ARGPTR
  2364.  
  2365.         INTEGER XZYAAB
  2366.  
  2367.         INTEGER LLCRHE,EQUAL,LLNEXT,LENGTH,ZYCADT,LLCREL,ZIAND,LLFIRS,
  2368.      +          ZYXGVA
  2369.         EXTERNAL LLCRHE,EQUAL,LLNEXT,LENGTH,ZYCADT,LLCREL,ZIAND,LLFIRS,
  2370.      +           ZYXGVA,LLINTO,SCOPY
  2371.  
  2372. C Duplicating an existing p.u. name?
  2373.         PTR=LLFIRS(SYMATR,SYMATR(ATRGLB+0))
  2374.  100    IF (PTR.NE.0) THEN
  2375.             IF (EQUAL(STRTXT(SYMBOL(2,SYMPTR)),
  2376.      +                SYMATR(PTR)).EQ.-2) THEN
  2377.                 ZYXAEN=-1
  2378.                 RETURN
  2379.             END IF
  2380.             PTR=LLNEXT(SYMATR,PTR)
  2381.             GOTO 100
  2382.         END IF
  2383. C No, duplicating an existing entry point name?
  2384.         IF (SYMATR(ATRGLB+3).NE.0)
  2385.      +      PTR=LLFIRS(SYMATR,SYMATR(ATRGLB+3))
  2386.  200    IF (PTR.NE.0) THEN
  2387.             IF (EQUAL(STRTXT(SYMBOL(2,SYMPTR)),
  2388.      +                SYMATR(PTR)).EQ.-2) THEN
  2389.                 ZYXAEN=-1
  2390.                 RETURN
  2391.             END IF
  2392.             PTR=LLNEXT(SYMATR,PTR)
  2393.             GOTO 200
  2394.         END IF
  2395. C No, then we add it.
  2396. C First make sure we have an entry point list.
  2397.         IF (SYMATR(ATRGLB+3).EQ.0)
  2398.      +      SYMATR(ATRGLB+3)=LLCRHE(SYMATR,0)
  2399. C Secondly, skip past name in parent program-unit's record
  2400.         PUGLOB=SYMATR(SYMBOL(8,PUSYM)+SYMBOL(7,PUSYM)+1)
  2401.  300    IF (SYMATR(PUGLOB).NE.129) THEN
  2402.             PUGLOB=PUGLOB+1
  2403.             GOTO 300
  2404.         END IF
  2405. C And create its descendent entry point list if necessary.
  2406.         IF (SYMATR(PUGLOB+6).EQ.0)
  2407.      +      SYMATR(PUGLOB+6)=LLCRHE(SYMATR,0)
  2408.         NAMLEN=LENGTH(STRTXT(SYMBOL(2,SYMPTR)))
  2409. C Create the global entry point block & link it to the global en list
  2410.         PTR=LLCREL(SYMATR,NAMLEN+6+SYMBOL(7,SYMPTR))
  2411.         CALL LLINTO(SYMATR,PTR,SYMATR(ATRGLB+3))
  2412. C Store a pointer to the global en block in the local en block
  2413.         SYMATR(SYMBOL(8,SYMPTR)+
  2414.      +         SYMBOL(7,SYMPTR)+1)=PTR
  2415. C Copy the name in
  2416.         CALL SCOPY(STRTXT,SYMBOL(2,SYMPTR),SYMATR,PTR)
  2417. C Create an element in the pu blocks entry list pointing to this
  2418.         PTR2=LLCREL(SYMATR,1)
  2419.         SYMATR(PTR2)=PTR
  2420.         CALL LLINTO(SYMATR,PTR2,SYMATR(PUGLOB+6))
  2421. C Now fill in the data ...
  2422.         PTR=PTR+NAMLEN
  2423. C Store canonicalised data type in global en block
  2424.         IF (SYMBOL(4,SYMPTR).NE.6) THEN
  2425.             SYMATR(PTR+1)=
  2426.      +          ZYCADT(SYMBOL(4,SYMPTR),
  2427.      +                 SYMBOL(5,SYMPTR))
  2428.             SYMATR(PTR+2)=0
  2429.         ELSE
  2430.             SYMATR(PTR+1)=6
  2431.             IF (SYMBOL(5,SYMPTR).LT.0) THEN
  2432.                 SYMATR(PTR+2)=
  2433.      +              ZYXGVA(-SYMBOL(5,SYMPTR))
  2434.             ELSE IF (SYMBOL(5,SYMPTR).GT.0) THEN
  2435.                 SYMATR(PTR+2)=SYMBOL(5,SYMPTR)
  2436.             ELSE
  2437.                 SYMATR(PTR+2)=1
  2438.             END IF
  2439.         END IF
  2440. C Store pointer to parent p.u.
  2441.         SYMATR(PTR+3)=
  2442.      +      SYMATR(SYMBOL(8,PUSYM)+SYMBOL(7,PUSYM)+1)
  2443. C Store number of arguments
  2444.         SYMATR(PTR+4)=SYMBOL(7,SYMPTR)
  2445. C Now comes the difficult bit: storing the argument data
  2446.         DO 600 I=0,SYMBOL(7,SYMPTR)-1
  2447. C ... first see if we can find the argument amongst the p.u. args
  2448.             PTR3=PUGLOB+7
  2449.             DO 400 PTR2=SYMBOL(8,PUSYM),
  2450.      +                  SYMBOL(8,PUSYM)+SYMBOL(7,PUSYM)-1
  2451.                 IF (SYMATR(PTR2).EQ.SYMATR(SYMBOL(8,SYMPTR)+I))
  2452.      +          THEN
  2453.                     SYMATR(PTR+6+I)=PTR3
  2454.                     GOTO 500
  2455.                 END IF
  2456.                 PTR3=PTR3+7
  2457.  400        CONTINUE
  2458. C ... not there - see if we can find it at some other entry point?
  2459. C [DO THIS LATER.  FOR NOW, JUST CREATE A NEW ARG BLOCK]
  2460.             PTR2=XZYAAB(7)
  2461.             SYMATR(PTR+6+I)=PTR2
  2462.             ARGPTR=SYMATR(SYMBOL(8,SYMPTR)+I)
  2463.             IF (ARGPTR.LT.1) THEN
  2464. C "label" dummy arguments don't have symbols attached...
  2465.                 SYMATR(PTR2+0)=10
  2466.                 SYMATR(PTR2+3)=3
  2467.                 GOTO 500
  2468.             END IF
  2469.             SYMATR(PTR2+0)=SYMBOL(4,ARGPTR)
  2470.             SYMATR(PTR2+1)=SYMBOL(5,ARGPTR)
  2471. C Store proper character/byte length of dummy argument
  2472.             IF (SYMBOL(5,ARGPTR).LT.0) THEN
  2473.                 SYMATR(PTR2+1)=
  2474.      +              ZYXGVA(-SYMBOL(5,ARGPTR))
  2475.             ELSE IF (SYMBOL(5,ARGPTR).EQ.0 .AND.
  2476.      +               SYMBOL(4,ARGPTR).EQ.6) THEN
  2477.                 SYMATR(PTR2+1)=1
  2478.             END IF
  2479. C Argument usage
  2480.             IF (ZIAND(SYMBOL(6,ARGPTR),
  2481.      +          16+32+64+65536).EQ.0)
  2482.      +      THEN
  2483.                 IF (ZIAND(SYMBOL(6,ARGPTR),131072).EQ.0)
  2484.      +          THEN
  2485.                     SYMATR(PTR2+2)=1
  2486.                 ELSE
  2487.                     SYMATR(PTR2+2)=0
  2488.                 END IF
  2489.             ELSE
  2490.                 SYMATR(PTR2+2)=2
  2491.             END IF
  2492. C Argument structure
  2493.             IF (SYMBOL(1,ARGPTR).EQ.7) THEN
  2494.                 SYMATR(PTR2+3)=2
  2495.             ELSE IF (SYMBOL(7,ARGPTR).NE.0) THEN
  2496.                 SYMATR(PTR2+3)=1
  2497.             ELSE
  2498.                 SYMATR(PTR2+3)=0
  2499.             END IF
  2500. C Argument size: (only for variables/arrays) (0=inf/adj)
  2501.             IF (SYMBOL(1,ARGPTR).EQ.5) THEN
  2502.                 SYMATR(PTR2+4)=
  2503.      +              SYMATR(SYMBOL(8,ARGPTR))
  2504.             ELSE
  2505.                 SYMATR(PTR2+4)=0
  2506.             END IF
  2507.             SYMATR(PTR2+5)=0
  2508.             SYMATR(PTR2+6)=0
  2509.  500        CONTINUE
  2510.  600    CONTINUE
  2511.         ZYXAEN=-2
  2512.  
  2513.         END
  2514. C ----------------------------------------------------------------------
  2515. C
  2516. C       $ A D D G _ C O M M O N   -   Add global symbol for common block
  2517. C
  2518.  
  2519.         INTEGER FUNCTION ZYXACO(SYMPTR)
  2520.         INTEGER SYMPTR
  2521.  
  2522. C---------------------------------------------------------
  2523. C    TOOLPACK/1    Release: 2.5
  2524. C---------------------------------------------------------
  2525.         COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
  2526.         INTEGER NSYMS,NPUS,PUIDX(250),
  2527.      +          SYMBOL(8,5003)
  2528.         LOGICAL MODFLG
  2529.  
  2530.         SAVE /XCSYMS/
  2531. C---------------------------------------------------------
  2532. C    TOOLPACK/1    Release: 2.5
  2533. C---------------------------------------------------------
  2534.         COMMON/XCSTRI/STRTXT,STRTBL,NSTRNG,TXTTOP
  2535.         INTEGER STRTXT(46339),STRTBL(7103),NSTRNG,TXTTOP
  2536.  
  2537.         SAVE /XCSTRI/
  2538.  
  2539. C---------------------------------------------------------
  2540. C    TOOLPACK/1    Release: 2.5
  2541. C---------------------------------------------------------
  2542.         COMMON/XCATRX/SYMATR,ATRGLB
  2543.         INTEGER SYMATR(69000),ATRGLB
  2544.         SAVE /XCATRX/
  2545.  
  2546.         INTEGER PUSYM
  2547.  
  2548.         INTEGER XZYAGC
  2549.  
  2550.         INTEGER ZYGPUS
  2551.         EXTERNAL ZYGPUS
  2552.  
  2553.         PUSYM=ZYGPUS(SYMBOL(3,SYMPTR))
  2554.         ZYXACO=XZYAGC(STRTXT(SYMBOL(2,SYMPTR)),
  2555.      +                          SYMBOL(6,SYMPTR),
  2556.      +                          MOD(SYMBOL(8,SYMPTR),3),
  2557.      +                          SYMBOL(8,SYMPTR)/3,
  2558.      +                          PUSYM,
  2559.      +                          SYMATR(SYMBOL(7,SYMPTR)))
  2560.         IF (ZYXACO.GT.0) THEN
  2561.             SYMBOL(8,SYMPTR)=ZYXACO
  2562.             ZYXACO=-2
  2563.         END IF
  2564.  
  2565.  
  2566.         END
  2567. C ----------------------------------------------------------------------
  2568. C
  2569. C       X $ A D D G _ C O M   -   Add global common symbol
  2570. C
  2571.  
  2572.         INTEGER FUNCTION XZYAGC(NAME,SIZE,TYPE,SAVED,PUSYM,USAGE)
  2573.         INTEGER NAME(*),SIZE,TYPE,SAVED,PUSYM,USAGE
  2574.  
  2575. C---------------------------------------------------------
  2576. C    TOOLPACK/1    Release: 2.5
  2577. C---------------------------------------------------------
  2578.         COMMON/XCATRX/SYMATR,ATRGLB
  2579.         INTEGER SYMATR(69000),ATRGLB
  2580.         SAVE /XCATRX/
  2581. C---------------------------------------------------------
  2582. C    TOOLPACK/1    Release: 2.5
  2583. C---------------------------------------------------------
  2584.         COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
  2585.         INTEGER NSYMS,NPUS,PUIDX(250),
  2586.      +          SYMBOL(8,5003)
  2587.         LOGICAL MODFLG
  2588.  
  2589.         SAVE /XCSYMS/
  2590.  
  2591.         INTEGER APTR,BLANK(8),CDTA,NAMLEN,PUGLOB,NARGS,USE(2)
  2592.  
  2593.         SAVE BLANK
  2594.  
  2595.         EQUIVALENCE(APTR,USE(1))
  2596.  
  2597.         INTEGER EQUAL,LENGTH,LLFIRS,LLNEXT,LLCREL,LLCRHE,LLCRED
  2598.         EXTERNAL EQUAL,LENGTH,SCOPY,LLFIRS,LLNEXT,LLCREL,LLCRHE,LLINTO,
  2599.      +           LLCRED
  2600.  
  2601.         DATA BLANK/36,67,79,77,77,79,78,129/
  2602.  
  2603. C First check that the common block name isn't the same as a p.u. name
  2604.         APTR=0
  2605.         IF (SYMATR(ATRGLB+0).NE.0)
  2606.      +      APTR=LLFIRS(SYMATR,SYMATR(ATRGLB+0))
  2607.  100    IF (APTR.NE.0) THEN
  2608.             IF (EQUAL(SYMATR(APTR),NAME).EQ.-2) THEN
  2609.                 XZYAGC=-65
  2610.                 RETURN
  2611.             END IF
  2612.             APTR=LLNEXT(SYMATR,APTR)
  2613.             GOTO 100
  2614.         END IF
  2615.  
  2616. C Or an entry point name
  2617.         IF (SYMATR(ATRGLB+3).NE.0)
  2618.      +      APTR=LLFIRS(SYMATR,SYMATR(ATRGLB+0))
  2619.  120    IF (APTR.NE.0) THEN
  2620.             IF (EQUAL(SYMATR(APTR),NAME).EQ.-2) THEN
  2621.                 XZYAGC=-65
  2622.                 RETURN
  2623.             END IF
  2624.             APTR=LLNEXT(SYMATR,APTR)
  2625.             GOTO 120
  2626.         END IF
  2627.  
  2628. C Prepare to record the usage of this common block in the global pu blk
  2629. C ... First find the global pu block
  2630.         NARGS=SYMBOL(7,PUSYM)
  2631.         PUGLOB=SYMATR(SYMBOL(8,PUSYM)+NARGS+1)
  2632. C ... Now skip past the name
  2633.  150    PUGLOB=PUGLOB+1
  2634.         IF (SYMATR(PUGLOB).NE.129) GOTO 150
  2635.         PUGLOB=PUGLOB+3
  2636. C ... Create the list header if there is none so far
  2637.         IF (SYMATR(PUGLOB).EQ.0) SYMATR(PUGLOB)=LLCRHE(SYMATR,0)
  2638. C ... Setup the usage data
  2639.         USE(2)=USAGE
  2640. C ...
  2641.         IF (SYMATR(ATRGLB+1).EQ.0)
  2642.      +      SYMATR(ATRGLB+1)=LLCRHE(SYMATR,0)
  2643.         APTR=LLFIRS(SYMATR,SYMATR(ATRGLB+1))
  2644.  200    IF (APTR.NE.0) THEN
  2645.             IF (EQUAL(SYMATR(APTR),NAME).EQ.-2) THEN
  2646.                 XZYAGC=APTR
  2647.                 CDTA=APTR+LENGTH(SYMATR(APTR))
  2648.                 IF (SIZE.NE.SYMATR(CDTA+1)) THEN
  2649.                     IF (EQUAL(NAME,BLANK).EQ.-3) XZYAGC=-64
  2650.                     SYMATR(CDTA+1)=MAX(SYMATR(CDTA+1),SIZE)
  2651.                 END IF
  2652.                 IF (TYPE.NE.SYMATR(CDTA+2))
  2653.      +              SYMATR(CDTA+2)=2
  2654. C If this is not a main program ...
  2655.                 IF (SAVED.NE.2) THEN
  2656.                     IF (SYMATR(CDTA+3).EQ.2) THEN
  2657. C Only previous occurrence was a main program - store new SAVE status
  2658.                         SYMATR(CDTA+3)=SAVED
  2659. C ... Must match previous SAVE status otherwise
  2660.                     ELSE IF (SAVED.NE.SYMATR(CDTA+3)) THEN
  2661.                         XZYAGC=-63
  2662.                     END IF
  2663.                 END IF
  2664.                 CALL LLINTO(SYMATR,LLCRED(SYMATR,2,USE),SYMATR(PUGLOB))
  2665.                 IF (SYMBOL(4,PUSYM).EQ.-2) THEN
  2666.                     SYMATR(CDTA+4)=SYMATR(CDTA+4)+1
  2667.                     IF (SYMATR(CDTA+4).GT.1)
  2668.      +                  XZYAGC=-66
  2669.                 END IF
  2670.                 RETURN
  2671.             ELSE
  2672.                 APTR=LLNEXT(SYMATR,APTR)
  2673.                 GOTO 200
  2674.             END IF
  2675.         END IF
  2676.         NAMLEN=LENGTH(NAME)
  2677.         APTR=LLCREL(SYMATR,5+NAMLEN)
  2678.         CALL LLINTO(SYMATR,LLCRED(SYMATR,2,USE),SYMATR(PUGLOB))
  2679.         CALL LLINTO(SYMATR,APTR,SYMATR(ATRGLB+1))
  2680.         CALL SCOPY(NAME,1,SYMATR,APTR)
  2681.         CDTA=APTR+NAMLEN
  2682.         SYMATR(CDTA+1)=SIZE
  2683.         SYMATR(CDTA+2)=TYPE
  2684.         SYMATR(CDTA+3)=SAVED
  2685.         IF (SYMBOL(4,PUSYM).EQ.-2) THEN
  2686.             SYMATR(CDTA+4)=1
  2687.         ELSE
  2688.             SYMATR(CDTA+4)=0
  2689.         END IF
  2690.         XZYAGC=APTR
  2691.  
  2692.         END
  2693. C ----------------------------------------------------------------------
  2694. C
  2695. C       $ A D D G _ P R O C   -   Add global symbol for external proc
  2696. C
  2697.  
  2698.         INTEGER FUNCTION ZYXAPR(SYMPTR)
  2699.         INTEGER SYMPTR
  2700.  
  2701. C---------------------------------------------------------
  2702. C    TOOLPACK/1    Release: 2.5
  2703. C---------------------------------------------------------
  2704.         COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
  2705.         INTEGER NSYMS,NPUS,PUIDX(250),
  2706.      +          SYMBOL(8,5003)
  2707.         LOGICAL MODFLG
  2708.  
  2709.         SAVE /XCSYMS/
  2710. C---------------------------------------------------------
  2711. C    TOOLPACK/1    Release: 2.5
  2712. C---------------------------------------------------------
  2713.         COMMON/XCATRX/SYMATR,ATRGLB
  2714.         INTEGER SYMATR(69000),ATRGLB
  2715.         SAVE /XCATRX/
  2716. C---------------------------------------------------------
  2717. C    TOOLPACK/1    Release: 2.5
  2718. C---------------------------------------------------------
  2719.         COMMON/XCSTRI/STRTXT,STRTBL,NSTRNG,TXTTOP
  2720.         INTEGER STRTXT(46339),STRTBL(7103),NSTRNG,TXTTOP
  2721.  
  2722.         SAVE /XCSTRI/
  2723.  
  2724.  
  2725.         INTEGER NARGS,CHRLEN,LPRPTR,NULL(2),PUSYM,DTYPE
  2726.  
  2727.         SAVE NULL
  2728.  
  2729.         INTEGER ZYXGVA,XZYAGP,XZYAP2,XZYAAB
  2730.  
  2731.         INTEGER ZIAND,ZYGPUS,ZYCADT
  2732.         EXTERNAL ZIAND,ZYGPUS,ZYCADT
  2733.  
  2734.         DATA NULL(1)/129/
  2735.  
  2736.         PUSYM=ZYGPUS(SYMBOL(3,SYMPTR))
  2737.         IF (SYMBOL(4,SYMPTR).EQ.6) THEN
  2738.             CHRLEN=SYMBOL(5,SYMPTR)
  2739.             IF (CHRLEN.EQ.0) CHRLEN=1
  2740.             IF (CHRLEN.LT.0) CHRLEN=ZYXGVA(-CHRLEN)
  2741.         ELSE
  2742.             DTYPE=ZYCADT(SYMBOL(4,SYMPTR),
  2743.      +                   SYMBOL(5,SYMPTR))
  2744.             CHRLEN=0
  2745.         END IF
  2746.         IF (ZIAND(SYMBOL(6,SYMPTR),8192+32768+
  2747.      +      2048).EQ.2048) THEN
  2748. C First create the lpr record as it hasn't been yet
  2749.             SYMBOL(7,SYMPTR)=XZYAAB(2)
  2750.             SYMATR(SYMBOL(7,SYMPTR)+1)=-1
  2751.             IF (ZIAND(SYMBOL(6,SYMPTR),4).NE.0) THEN
  2752. C Indirect routine only passed out as actual parameter
  2753.                 ZYXAPR=XZYAP2(NULL,
  2754.      +                                  -1,
  2755.      +                                  DTYPE,
  2756.      +                                  CHRLEN,
  2757.      +                                  PUSYM,
  2758.      +                                  SYMPTR)
  2759.             ELSE
  2760. C Routine is only passed out as an actual arg - special x$addg call
  2761.                 ZYXAPR=XZYAP2(STRTXT(SYMBOL(2,SYMPTR)),
  2762.      +                                  -1,
  2763.      +                                  DTYPE,
  2764.      +                                  CHRLEN,
  2765.      +                                  PUSYM,
  2766.      +                                  SYMPTR)
  2767.             END IF
  2768.         ELSE IF (SYMBOL(7,SYMPTR).EQ.0) THEN
  2769.             ZYXAPR=-62
  2770.         ELSE IF (ZIAND(SYMBOL(6,SYMPTR),4).NE.0) THEN
  2771. C Indirect Reference
  2772.             LPRPTR=SYMBOL(7,SYMPTR)
  2773.             NARGS=SYMATR(LPRPTR+1)
  2774.             ZYXAPR=XZYAGP(NULL,
  2775.      +                             NARGS,
  2776.      +                             DTYPE,
  2777.      +                             CHRLEN,
  2778.      +                             SYMATR(LPRPTR+2),
  2779.      +                             PUSYM,
  2780.      +                             SYMPTR)
  2781.         ELSE
  2782.             LPRPTR=SYMBOL(7,SYMPTR)
  2783.             NARGS=SYMATR(LPRPTR+1)
  2784.             ZYXAPR=XZYAGP(STRTXT(SYMBOL(2,SYMPTR)),
  2785.      +                             NARGS,
  2786.      +                             DTYPE,
  2787.      +                             CHRLEN,
  2788.      +                             SYMATR(LPRPTR+2),
  2789.      +                             PUSYM,
  2790.      +                             SYMPTR)
  2791.         END IF
  2792.  
  2793.         END
  2794. C ----------------------------------------------------------------------
  2795. C
  2796. C       X $ A D D G _ P R O C   -   Add global symbol for external proc
  2797. C
  2798.  
  2799.         INTEGER FUNCTION XZYAGP(NAME,NARGS,DTYPE,CHRLEN,ARGBLK,
  2800.      +                               PUSYM,SYMPTR)
  2801.         INTEGER NAME(*),NARGS,DTYPE,CHRLEN,ARGBLK(*),PUSYM,SYMPTR
  2802.  
  2803.         INTEGER XZYAP2
  2804.         ENTRY XZYAP2(NAME,NARGS,DTYPE,CHRLEN,PUSYM,SYMPTR)
  2805.  
  2806. C---------------------------------------------------------
  2807. C    TOOLPACK/1    Release: 2.5
  2808. C---------------------------------------------------------
  2809.         COMMON/XCATRX/SYMATR,ATRGLB
  2810.         INTEGER SYMATR(69000),ATRGLB
  2811.         SAVE /XCATRX/
  2812. C---------------------------------------------------------
  2813. C    TOOLPACK/1    Release: 2.5
  2814. C---------------------------------------------------------
  2815.         COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
  2816.         INTEGER NSYMS,NPUS,PUIDX(250),
  2817.      +          SYMBOL(8,5003)
  2818.         LOGICAL MODFLG
  2819.  
  2820.         SAVE /XCSYMS/
  2821.  
  2822.         INTEGER APTR,PUPTR,EPTR,N,NEWTYP,EDATA,NAMLEN,TMP,CBPTR,PUDATA,
  2823.      +          I,ARGNUM
  2824.  
  2825.         INTEGER ZYXCPR,XZYTPC,ZYXCEF
  2826.  
  2827.         INTEGER EQUAL,LENGTH,LLFIRS,LLNEXT,LLCRHE,LLCREL
  2828.         EXTERNAL EQUAL,LENGTH,LLFIRS,LLNEXT,LLCRHE,LLCREL,LLINTO,SCOPY,
  2829.      +           ERROR
  2830.  
  2831. C Step One: For indirect refs, find argument number & skip checks
  2832.         IF (NAME(1).EQ.129) THEN
  2833.             APTR=SYMBOL(8,PUSYM)
  2834.             ARGNUM=1
  2835.  100        IF (SYMATR(APTR).NE.SYMPTR) THEN
  2836.                 APTR=APTR+1
  2837.                 ARGNUM=ARGNUM+1
  2838.                 IF (ARGNUM.LE.SYMBOL(7,PUSYM)) GOTO 100
  2839. C Not found - try ENTRY points
  2840. C Don't have to look backwards from PU symbol to first symbol of p.u.
  2841. C because a SUBROUTINE/FUNCTION symbol must ALWAYS precede all entry
  2842. C points.
  2843.                 I=PUSYM+1
  2844.  150            IF (I.LE.NSYMS) THEN
  2845.                     IF (SYMBOL(3,I).EQ.SYMBOL(3,PUSYM)
  2846.      +              )THEN
  2847.                         IF (SYMBOL(1,I).EQ.9) THEN
  2848. C Found an entry point - check it out.
  2849.                             PUSYM=I
  2850.                             ARGNUM=1
  2851.                             APTR=SYMBOL(8,PUSYM)
  2852.                             GOTO 100
  2853.                         END IF
  2854.                         I=I+1
  2855.                         GOTO 150
  2856.                     END IF
  2857.                 END IF
  2858.                 CALL ERROR('ARG WHICH IS INDIRECT REF NOT FOUND')
  2859.             END IF
  2860.             GOTO 600
  2861.         ELSE
  2862.             ARGNUM=0
  2863.         END IF
  2864.  
  2865. C Step Two: Check for a matching program-unit
  2866.         PUPTR=LLFIRS(SYMATR,SYMATR(ATRGLB+0))
  2867.  200    IF (EQUAL(SYMATR(PUPTR),NAME).EQ.-2) THEN
  2868.             SYMATR(SYMBOL(7,SYMPTR)+0)=PUPTR
  2869.             PUDATA=PUPTR+LENGTH(SYMATR(PUPTR))
  2870.             IF (DTYPE.NE.SYMATR(PUDATA+1) .OR.
  2871.      +          SYMATR(PUDATA+2).NE.CHRLEN .AND.
  2872.      +          SYMATR(PUDATA+2).GT.0 .AND. CHRLEN.GT.0) THEN
  2873.                 XZYAGP=-55
  2874.             ELSE IF (NARGS.EQ.-1) THEN
  2875.                 XZYAGP=-2
  2876.                 CALL XZYAGD(3,ARGNUM,SYMPTR,PUSYM,PUPTR)
  2877.             ELSE IF (NARGS.NE.SYMATR(PUDATA+4)) THEN
  2878.                 XZYAGP=-56
  2879.             ELSE
  2880.                 XZYAGP=
  2881.      +            ZYXCPR(SYMATR(PUDATA+7),NARGS,ARGBLK)
  2882.                 IF (XZYAGP.EQ.-2)
  2883.      +              CALL XZYAGD(1,ARGNUM,SYMPTR,PUSYM,
  2884.      +                               PUPTR)
  2885.             END IF
  2886.             RETURN
  2887.         ELSE
  2888.             PUPTR=LLNEXT(SYMATR,PUPTR)
  2889.             IF (PUPTR.NE.0) GOTO 200
  2890.         END IF
  2891.  
  2892. C Step Two-A: Look for a matching ENTRY point.
  2893.         IF (SYMATR(ATRGLB+3).NE.0) THEN
  2894.             PUPTR=LLFIRS(SYMATR,SYMATR(ATRGLB+3))
  2895.  250        IF (EQUAL(SYMATR(PUPTR),NAME).EQ.-2) THEN
  2896.                 SYMATR(SYMBOL(7,SYMPTR)+0)=PUPTR
  2897.                 PUDATA=PUPTR+LENGTH(SYMATR(PUPTR))
  2898.                 IF (DTYPE.NE.SYMATR(PUDATA+1) .OR.
  2899.      +              SYMATR(PUDATA+2).NE.CHRLEN .AND.
  2900.      +              SYMATR(PUDATA+2).GT.0 .AND. CHRLEN.GT.0)
  2901.      +          THEN
  2902.                     XZYAGP=-55
  2903.                 ELSE IF (NARGS.EQ.-1) THEN
  2904.                     XZYAGP=-2
  2905.                     CALL XZYAGD(3,ARGNUM,SYMPTR,PUSYM,
  2906.      +                               PUPTR)
  2907.                 ELSE IF (NARGS.NE.SYMATR(PUDATA+4)) THEN
  2908.                     XZYAGP=-56
  2909.                 ELSE
  2910.                     XZYAGP=ZYXCEF(SYMATR(PUDATA+6),
  2911.      +                                         NARGS,ARGBLK)
  2912.                     IF (XZYAGP.EQ.-2)
  2913.      +                  CALL XZYAGD(1,ARGNUM,SYMPTR,
  2914.      +                                   PUSYM,PUPTR)
  2915.                 END IF
  2916.                 RETURN
  2917.             ELSE
  2918.                 PUPTR=LLNEXT(SYMATR,PUPTR)
  2919.                 IF (PUPTR.NE.0) GOTO 250
  2920.             END IF
  2921.         END IF
  2922.  
  2923. C Step Three: Check for a matching common block (this is an error!)
  2924.         IF (SYMATR(ATRGLB+1).NE.0) THEN
  2925.             CBPTR=LLFIRS(SYMATR,SYMATR(ATRGLB+1))
  2926.  300        IF (EQUAL(SYMATR(CBPTR),NAME).EQ.-2) THEN
  2927.                 XZYAGP=-61
  2928.                 RETURN
  2929.             END IF
  2930.             CBPTR=LLNEXT(SYMATR,CBPTR)
  2931.             IF (CBPTR.NE.0) GOTO 300
  2932.         END IF
  2933.  
  2934. C Step Four: Check for an already existing external reference
  2935.         IF (SYMATR(ATRGLB+2).EQ.0)
  2936.      +      SYMATR(ATRGLB+2)=LLCRHE(SYMATR,0)
  2937.         EPTR=LLFIRS(SYMATR,SYMATR(ATRGLB+2))
  2938.         IF (EPTR.GT.0) THEN
  2939.  400        IF (EQUAL(SYMATR(EPTR),NAME).EQ.-2) THEN
  2940.                 SYMATR(SYMBOL(7,SYMPTR)+0)=-EPTR
  2941. C Check consistency
  2942.                 EDATA=EPTR+LENGTH(SYMATR(EPTR))
  2943.                 IF (DTYPE.NE.SYMATR(EDATA+1)) THEN
  2944.                     XZYAGP=-51
  2945.                     RETURN
  2946.                 END IF
  2947.                 IF (CHRLEN.NE.SYMATR(EDATA+2)) THEN
  2948.                     SYMATR(EDATA+2)=0
  2949.                 END IF
  2950. C Check for it only being passed as an actual argument
  2951.                 IF (NARGS.EQ.-1) THEN
  2952.                     XZYAP2=-2
  2953.                     CALL XZYAGD(4,ARGNUM,SYMPTR,PUSYM,
  2954.      +                               EPTR)
  2955.                     RETURN
  2956.                 END IF
  2957.                 IF (NARGS.NE.SYMATR(EDATA+3)) THEN
  2958.                     XZYAGP=-52
  2959.                     RETURN
  2960.                 END IF
  2961.                 EDATA=EDATA+4
  2962.                 APTR=1
  2963.                 TMP=NARGS
  2964.  500            IF (TMP.GT.0) THEN
  2965.                     NEWTYP=XZYTPC(MOD(ARGBLK(APTR+0),8),
  2966.      +                                 MOD(SYMATR(EDATA+0),8))
  2967.                     IF (NEWTYP.EQ.-1) THEN
  2968.                         XZYAGP=-53
  2969.                         RETURN
  2970.                     END IF
  2971.                     SYMATR(EDATA+0)=
  2972.      +                  (SYMATR(EDATA+0)/8)*8+NEWTYP
  2973. C Arguments must match in type (page 15-8, section 15.5.2.2) with
  2974. C the FUNCTION/SUBROUTINE declaration - they obviously cannot if they
  2975. C are of differing types in different references!
  2976.                     IF (ARGBLK(APTR+0)/8.NE.
  2977.      +                  SYMATR(EDATA+0)/8) THEN
  2978.                         XZYAGP=-54
  2979.                         RETURN
  2980.                     END IF
  2981.                     IF (SYMATR(EDATA+0)/8+(-3).EQ.
  2982.      +                  6) THEN
  2983.                         SYMATR(EDATA+2)=
  2984.      +                      MIN(SYMATR(EDATA+2),
  2985.      +                          ARGBLK(APTR+2))
  2986.                         SYMATR(EDATA+3)=
  2987.      +                      MAX(SYMATR(EDATA+3),
  2988.      +                          ARGBLK(APTR+3))
  2989.                         EDATA=EDATA+4
  2990.                         APTR=APTR+4
  2991.                     ELSE
  2992.                         EDATA=EDATA+2
  2993.                         APTR=APTR+2
  2994.                     END IF
  2995.                     TMP=TMP-1
  2996.                     GOTO 500
  2997.                 END IF
  2998.                 XZYAGP=-2
  2999.                 CALL XZYAGD(2,ARGNUM,SYMPTR,PUSYM,EPTR)
  3000.                 RETURN
  3001.             ELSE
  3002.                 EPTR=LLNEXT(SYMATR,EPTR)
  3003.                 IF (EPTR.NE.0) GOTO 400
  3004.             END IF
  3005.         END IF
  3006.  
  3007. C Step 5: Add the new reference to the database
  3008. C (but not if only passed out as an actual argument)
  3009.  600    IF (NARGS.EQ.-1) THEN
  3010.             IF (NAME(1).EQ.129) THEN
  3011.                 CALL XZYAGD(6,ARGNUM,SYMPTR,PUSYM,EPTR)
  3012.             ELSE
  3013.                 CALL XZYAGD(7,ARGNUM,SYMPTR,PUSYM,EPTR)
  3014.             END IF
  3015.             XZYAP2=-2
  3016.             RETURN
  3017.         END IF
  3018.  
  3019. C Make sure we have a header record
  3020.         IF (SYMATR(ATRGLB+2).EQ.0)
  3021.      +      SYMATR(ATRGLB+2)=LLCRHE(SYMATR,0)
  3022. C Work out how long current proc block is
  3023.         N=1
  3024.         TMP=NARGS
  3025.  700    IF (TMP.GT.0) THEN
  3026.             IF (ARGBLK(N+0)/8+(-3).EQ.6) THEN
  3027.                 N=N+4
  3028.             ELSE
  3029.                 N=N+2
  3030.             END IF
  3031.             TMP=TMP-1
  3032.             GOTO 700
  3033.         END IF
  3034.         N=N-1
  3035.  
  3036. C And add it
  3037.         NAMLEN=LENGTH(NAME)
  3038.         EPTR=LLCREL(SYMATR,NAMLEN+4+N)
  3039.         IF (NAME(1).EQ.129) THEN
  3040.             CALL XZYAGD(5,ARGNUM,SYMPTR,PUSYM,EPTR)
  3041.         ELSE IF (NARGS.GE.0) THEN
  3042.             CALL XZYAGD(2,ARGNUM,SYMPTR,PUSYM,EPTR)
  3043.         ELSE
  3044.             CALL XZYAGD(4,ARGNUM,SYMPTR,PUSYM,EPTR)
  3045.         END IF
  3046.         CALL LLINTO(SYMATR,EPTR,SYMATR(ATRGLB+2))
  3047.         CALL SCOPY(NAME,1,SYMATR,EPTR)
  3048.         SYMATR(SYMBOL(7,SYMPTR)+0)=-EPTR
  3049.         EPTR=EPTR+NAMLEN
  3050.         SYMATR(EPTR+1)=DTYPE
  3051.         SYMATR(EPTR+2)=CHRLEN
  3052.         SYMATR(EPTR+3)=NARGS
  3053.         EPTR=EPTR+4
  3054.         N=1
  3055.         DO 800 I=1,NARGS
  3056.             SYMATR(EPTR+0)=ARGBLK(N+0)
  3057.             SYMATR(EPTR+1)=0
  3058.             IF (ARGBLK(N+0)/8+(-3).EQ.6) THEN
  3059.                 SYMATR(EPTR+2)=ARGBLK(N+2)
  3060.                 SYMATR(EPTR+3)=ARGBLK(N+3)
  3061.                 EPTR=EPTR+4
  3062.                 N=N+4
  3063.             ELSE
  3064.                 EPTR=EPTR+2
  3065.                 N=N+2
  3066.             END IF
  3067.  800    CONTINUE
  3068.         XZYAGP=-2
  3069.  
  3070.         END
  3071. C ----------------------------------------------------------------------
  3072. C
  3073. C       X $ A D D G _ D E S C   -   Add descendant routine to global pu
  3074. C
  3075. C       This adds the routine as a descendent both to the program-unit
  3076. C       and to any dummy arguments which are passed down to it.
  3077. C
  3078.  
  3079.         SUBROUTINE XZYAGD(TYPE,NUMBER,SYMPTR,PUSYM,GSYPTR)
  3080.         INTEGER TYPE,NUMBER,SYMPTR,PUSYM,GSYPTR
  3081.  
  3082. C---------------------------------------------------------
  3083. C    TOOLPACK/1    Release: 2.5
  3084. C---------------------------------------------------------
  3085.         COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
  3086.         INTEGER NSYMS,NPUS,PUIDX(250),
  3087.      +          SYMBOL(8,5003)
  3088.         LOGICAL MODFLG
  3089.  
  3090.         SAVE /XCSYMS/
  3091. C---------------------------------------------------------
  3092. C    TOOLPACK/1    Release: 2.5
  3093. C---------------------------------------------------------
  3094.         COMMON/XCATRX/SYMATR,ATRGLB
  3095.         INTEGER SYMATR(69000),ATRGLB
  3096.         SAVE /XCATRX/
  3097. C---------------------------------------------------------
  3098. C    TOOLPACK/1    Release: 2.5
  3099. C---------------------------------------------------------
  3100.         COMMON/XCPAHP/USHEAD,PAHEAD,PAHEAP
  3101.         INTEGER USHEAD,PAHEAD,PAHEAP(11000)
  3102.  
  3103.         SAVE /XCPAHP/
  3104.  
  3105.         INTEGER DESCND(6),PUGLOB,DESREC,NARGS,P,LPRD,P1,P2,ARGNUM,N
  3106.  
  3107.         INTEGER LLCRED,LLCRHE,LLFIRS,LLNEXT
  3108.         EXTERNAL LLINTO,LLCRED,LLCRHE,LLFIRS,LLNEXT,ERROR
  3109.  
  3110. C First add it to the program-unit as a whole.
  3111. C Prepare program-unit's descendant list
  3112.         PUGLOB=SYMATR(SYMBOL(8,PUSYM)+SYMBOL(7,PUSYM)+1)
  3113.  100    IF (SYMATR(PUGLOB).NE.129) THEN
  3114.             PUGLOB=PUGLOB+1
  3115.             GOTO 100
  3116.         END IF
  3117.         IF (SYMBOL(1,PUSYM).EQ.4) THEN
  3118.             PUGLOB=PUGLOB+5
  3119.         ELSE
  3120.             PUGLOB=PUGLOB+5
  3121.         END IF
  3122.         IF (TYPE.NE.7) THEN
  3123.             IF (SYMATR(PUGLOB).EQ.0) SYMATR(PUGLOB)=LLCRHE(SYMATR,0)
  3124.             DESCND(1)=TYPE
  3125.             DESCND(2)=GSYPTR
  3126.             DESCND(3)=NUMBER
  3127.             DESREC=LLCRED(SYMATR,3,DESCND)
  3128.             CALL LLINTO(SYMATR,DESREC,SYMATR(PUGLOB))
  3129.         END IF
  3130.  
  3131. C Now check for any dummy arguments passed down.
  3132.         IF (SYMBOL(7,SYMPTR).EQ.0)
  3133.      +      CALL ERROR('XZYAGD: NO LPR RECORD FOUND')
  3134.         NARGS=SYMATR(SYMBOL(7,SYMPTR)+1)
  3135.         IF (NARGS.LE.0) RETURN
  3136.         P=SYMBOL(7,SYMPTR)+2
  3137.         ARGNUM=1
  3138.         IF (SYMBOL(1,PUSYM).EQ.4) THEN
  3139.             PUGLOB=PUGLOB+7-5
  3140.         ELSE
  3141.             PUGLOB=PUGLOB+6-5
  3142.         END IF
  3143.  200    IF (SYMATR(P+1).NE.0) THEN
  3144. C Found a descendent list - process it
  3145.             LPRD=LLFIRS(SYMATR,SYMATR(P+1))
  3146.  300        IF (SYMATR(LPRD).EQ.6) THEN
  3147. C ... dummy argument passed down
  3148.                 P1=SYMBOL(8,PUSYM)
  3149.                 P2=PUGLOB
  3150.                 N=SYMBOL(7,PUSYM)
  3151.  400            IF (SYMATR(P1).NE.SYMATR(LPRD+1)) THEN
  3152.                     IF (SYMBOL(1,PUSYM).EQ.4) THEN
  3153.                         P2=P2+7
  3154.                     ELSE
  3155.                         P2=P2+1
  3156.                     END IF
  3157.                     P1=P1+1
  3158.                     N=N-1
  3159.                     IF (N.GT.0) GOTO 400
  3160. C If not found then do absolutely nothing (must be an ENTRY argument)
  3161.                 ELSE
  3162. C Found the matching argument - add to its passage list
  3163.                     IF (SYMBOL(1,PUSYM).EQ.4) THEN
  3164.                         P2=P2+5
  3165.                     ELSE
  3166.                         P2=SYMATR(P2)+5
  3167.                     END IF
  3168.                     IF (SYMATR(P2).EQ.0)
  3169.      +                  SYMATR(P2)=LLCRHE(SYMATR,0)
  3170.                     DESCND(1)=ARGNUM
  3171.                     DESCND(2)=DESREC
  3172.                     CALL LLINTO(SYMATR,LLCRED(SYMATR,2,DESCND),
  3173.      +                                 SYMATR(P2))
  3174.                 END IF
  3175.             ELSE IF (SYMATR(LPRD).EQ.0) THEN
  3176. C ... Direct procedure passed down
  3177.                 DESCND(1+0)=ARGNUM
  3178.                 DESCND(1+1)=SYMPTR
  3179.                 DESCND(1+2)=SYMATR(LPRD+1)
  3180.                 DESCND(1+3)=PUSYM
  3181.                 DESCND(1+4)=SYMATR(LPRD+2)
  3182.                 CALL LLINTO(PAHEAP,LLCRED(PAHEAP,5,DESCND),PAHEAD)
  3183.             ELSE
  3184. C ... Possibly unsafe ref - store in PAHEAP for later
  3185.                 DESCND(1+1)=ARGNUM
  3186.                 DESCND(1+3)=PUSYM
  3187.                 DESCND(1+0)=SYMATR(LPRD)
  3188.                 DESCND(1+4)=SYMATR(LPRD+2)
  3189.                 DESCND(1+2)=SYMATR(LPRD+1)
  3190.                 DESCND(1+5)=SYMPTR
  3191.                 CALL LLINTO(PAHEAP,LLCRED(PAHEAP,6,DESCND),
  3192.      +                      USHEAD)
  3193.             END IF
  3194. C Process next item on descendent list
  3195.             LPRD=LLNEXT(SYMATR,LPRD)
  3196.             IF (LPRD.NE.0) GOTO 300
  3197.         END IF
  3198.         IF (SYMATR(P+0)/8+(-3).EQ.6) THEN
  3199.             P=P+4
  3200.         ELSE
  3201.             P=P+2
  3202.         END IF
  3203.         ARGNUM=ARGNUM+1
  3204.         IF (ARGNUM.LE.NARGS) GOTO 200
  3205.  
  3206.         END
  3207. C ----------------------------------------------------------------------
  3208. C
  3209. C       $ C H E C K _ P R O C   -   Check proc/pu consistency
  3210. C
  3211.  
  3212.         INTEGER FUNCTION ZYXCPR(PU,NPRARG,PRARGS)
  3213.         INTEGER PU(*),NPRARG,PRARGS(*)
  3214.  
  3215.         INTEGER P1,P2,N
  3216.  
  3217.         INTEGER XZYCKA
  3218.  
  3219.         N=NPRARG
  3220.         P1=1
  3221.         P2=1
  3222.         ZYXCPR=-2
  3223.         IF (N.GT.0) THEN
  3224. 100         ZYXCPR=XZYCKA(PU(P1),PRARGS(P2))
  3225.             IF (ZYXCPR.NE.-2) RETURN
  3226.             IF (PU(P1+0).EQ.6) THEN
  3227.                 P2=P2+4
  3228.             ELSE
  3229.                 P2=P2+2
  3230.             END IF
  3231.             P1=P1+7
  3232.             N=N-1
  3233.             IF (N.GT.0) GOTO 100
  3234.         END IF
  3235.  
  3236.         END
  3237. C ----------------------------------------------------------------------
  3238. C
  3239. C       $ C H K _ E N T R Y _ R E F   -   Check entry/proc consistency
  3240. C
  3241.  
  3242.         INTEGER FUNCTION ZYXCEF(EARGS,NARGS,PRARGS)
  3243.         INTEGER EARGS(*),NARGS,PRARGS(*)
  3244.  
  3245. C---------------------------------------------------------
  3246. C    TOOLPACK/1    Release: 2.5
  3247. C---------------------------------------------------------
  3248.         COMMON/XCATRX/SYMATR,ATRGLB
  3249.         INTEGER SYMATR(69000),ATRGLB
  3250.         SAVE /XCATRX/
  3251.  
  3252.         INTEGER P1,P2
  3253.  
  3254.         INTEGER XZYCKA
  3255.  
  3256.         P1=1
  3257.         P2=1
  3258.         ZYXCEF=-2
  3259.         IF (NARGS.GT.0) THEN
  3260. 100         ZYXCEF=XZYCKA(SYMATR(EARGS(P1)),PRARGS(P2))
  3261.             IF (ZYXCEF.NE.-2) RETURN
  3262.             IF (SYMATR(EARGS(P1)+0).EQ.6) THEN
  3263.                 P2=P2+4
  3264.             ELSE
  3265.                 P2=P2+2
  3266.             END IF
  3267.             P1=P1+1
  3268.             IF (P1.LE.NARGS) GOTO 100
  3269.         END IF
  3270.  
  3271.         END
  3272. C ----------------------------------------------------------------------
  3273. C
  3274. C       X $ C H E C K _ A R G   -   Check GPU/LPR argument compatibility
  3275. C
  3276.  
  3277.         INTEGER FUNCTION XZYCKA(GPUARG,LPRARG)
  3278.         INTEGER GPUARG(0:7-1),LPRARG(0:*)
  3279.  
  3280.         LOGICAL ZYXCAS
  3281.  
  3282. C Arg: Must have the same type
  3283.         IF (GPUARG(0).NE.
  3284.      +      LPRARG(0)/8+(-3)) THEN
  3285.             XZYCKA=-57
  3286. C Arg: If fixed-length char, must be at least as long
  3287.         ELSE IF (GPUARG(0).EQ.6 .AND.
  3288.      +           LPRARG(2).NE.0 .AND.
  3289.      +           LPRARG(2).LT.GPUARG(1)) THEN
  3290.             XZYCKA=-60
  3291. C Arg: Must match structure (array/proc/label/scalar)
  3292.         ELSE IF (.NOT.ZYXCAS(GPUARG(3),
  3293.      +                             MOD(LPRARG(0),8))) THEN
  3294.             XZYCKA=-59
  3295.         ELSE
  3296.             XZYCKA=-2
  3297.         END IF
  3298.  
  3299.         END
  3300. C ----------------------------------------------------------------------
  3301. C
  3302. C       $ A D D G _ P A S S   -   Add global argument passage records
  3303. C
  3304.  
  3305.         SUBROUTINE ZYXAAP
  3306.  
  3307. C---------------------------------------------------------
  3308. C    TOOLPACK/1    Release: 2.5
  3309. C---------------------------------------------------------
  3310.         COMMON/XCATRX/SYMATR,ATRGLB
  3311.         INTEGER SYMATR(69000),ATRGLB
  3312.         SAVE /XCATRX/
  3313. C---------------------------------------------------------
  3314. C    TOOLPACK/1    Release: 2.5
  3315. C---------------------------------------------------------
  3316.         COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
  3317.         INTEGER NSYMS,NPUS,PUIDX(250),
  3318.      +          SYMBOL(8,5003)
  3319.         LOGICAL MODFLG
  3320.  
  3321.         SAVE /XCSYMS/
  3322. C---------------------------------------------------------
  3323. C    TOOLPACK/1    Release: 2.5
  3324. C---------------------------------------------------------
  3325.         COMMON/XCPAHP/USHEAD,PAHEAD,PAHEAP
  3326.         INTEGER USHEAD,PAHEAD,PAHEAP(11000)
  3327.  
  3328.         SAVE /XCPAHP/
  3329. C---------------------------------------------------------
  3330. C    TOOLPACK/1    Release: 2.5
  3331. C---------------------------------------------------------
  3332.         COMMON/XCSTRI/STRTXT,STRTBL,NSTRNG,TXTTOP
  3333.         INTEGER STRTXT(46339),STRTBL(7103),NSTRNG,TXTTOP
  3334.  
  3335.         SAVE /XCSTRI/
  3336.  
  3337.  
  3338.         INTEGER PAREC,ARGSYM,GPRSYM,GASYM,P,GP,INHREC(4),I,
  3339.      +          CHRLEN,STATUS
  3340.  
  3341.         INTEGER ZYXGVA,XZYAP2
  3342.  
  3343.         INTEGER LLFIRS,LLNEXT,LLCRHE,LLCRED,LLHEAD
  3344.         EXTERNAL LLFIRS,LLNEXT,LLCRHE,LLCRED,LLHEAD,LLINTO,ERROR
  3345.  
  3346.         PAREC=LLFIRS(PAHEAP,PAHEAD)
  3347.         IF (PAREC.NE.0) THEN
  3348.  100        ARGSYM=PAHEAP(PAREC+2)
  3349.             GASYM=SYMATR(SYMBOL(7,ARGSYM)+0)
  3350.             IF (GASYM.EQ.0) THEN
  3351. C The routine being passed down has never been called directly and does
  3352. C not occur in this file - so we must create a special g_ext record
  3353.                 CHRLEN=SYMBOL(5,ARGSYM)
  3354.                 IF (CHRLEN.LT.0) THEN
  3355.                     CHRLEN=ZYXGVA(-CHRLEN)
  3356.                 ELSE IF (SYMBOL(4,ARGSYM).EQ.6 .AND.
  3357.      +                   CHRLEN.EQ.0) THEN
  3358.                     CHRLEN=1
  3359.                 END IF
  3360.                 STATUS=XZYAP2(STRTXT(SYMBOL(2,ARGSYM)),
  3361.      +                              -2,
  3362.      +                              SYMBOL(4,ARGSYM),
  3363.      +                              CHRLEN,
  3364.      +                              PAHEAP(PAREC+3),
  3365.      +                              ARGSYM)
  3366.                 IF (STATUS.NE.-2) CALL ERROR('ZYXAAP: FAILED')
  3367.                 GASYM=SYMATR(SYMBOL(7,ARGSYM)+0)
  3368.             END IF
  3369.             GPRSYM=SYMATR(
  3370.      +          SYMBOL(7,PAHEAP(PAREC+1))+0)
  3371.             GP=ABS(GPRSYM)
  3372.  200        IF (SYMATR(GP).NE.129) THEN
  3373.                 GP=GP+1
  3374.                 GOTO 200
  3375.             END IF
  3376.             IF (GPRSYM.GT.0) THEN
  3377. C Passed down to a satisfied reference - we have a global pu record
  3378. C or perhaps a global entry record
  3379.                 IF (LLHEAD(SYMATR,GPRSYM).EQ.SYMATR(ATRGLB+0))
  3380.      +          THEN
  3381.                     P=GP+7+
  3382.      +                (PAHEAP(PAREC+0)-1)*7+
  3383.      +                6
  3384.                 ELSE
  3385.                     P=GP+6+(PAHEAP(PAREC+0)-1)
  3386.                     P=SYMATR(P)+6
  3387.                 END IF
  3388.             ELSE IF (GPRSYM.LT.0) THEN
  3389. C Passed down to an unsatisfied reference - make do with a g_ext record
  3390.                 P=GP+4
  3391.                 DO 300 I=2,PAHEAP(PAREC+0)
  3392.                     IF (SYMATR(P+0)/8+(-3).EQ.6)
  3393.      +              THEN
  3394.                         P=P+4
  3395.                     ELSE
  3396.                         P=P+2
  3397.                     END IF
  3398.  300            CONTINUE
  3399.                 P=P+1
  3400.             END IF
  3401.             IF (SYMATR(P).EQ.0) SYMATR(P)=LLCRHE(SYMATR,0)
  3402.             INHREC(1+0)=0
  3403.             INHREC(1+3)=GASYM
  3404. C Turn S_PU symbol pointer into global pu record pointer
  3405.             INHREC(1+1)=SYMATR(
  3406.      +          SYMBOL(8,PAHEAP(PAREC+3))+
  3407.      +          SYMBOL(7,PAHEAP(PAREC+3))+1)
  3408.             INHREC(1+2)=PAHEAP(PAREC+4)
  3409.             CALL LLINTO(SYMATR,LLCRED(SYMATR,4,INHREC),
  3410.      +                         SYMATR(P))
  3411.             PAREC=LLNEXT(PAHEAP,PAREC)
  3412.             IF (PAREC.GT.0) GOTO 100
  3413.         END IF
  3414.  
  3415.         END
  3416. C ----------------------------------------------------------------------
  3417. C
  3418. C       $ A D D G _ U N S A F E   -   Adds global unsafe ref check rcds
  3419. C
  3420.  
  3421.         SUBROUTINE ZYXAUS
  3422.  
  3423. C---------------------------------------------------------
  3424. C    TOOLPACK/1    Release: 2.5
  3425. C---------------------------------------------------------
  3426.         COMMON/XCATRX/SYMATR,ATRGLB
  3427.         INTEGER SYMATR(69000),ATRGLB
  3428.         SAVE /XCATRX/
  3429. C---------------------------------------------------------
  3430. C    TOOLPACK/1    Release: 2.5
  3431. C---------------------------------------------------------
  3432.         COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
  3433.         INTEGER NSYMS,NPUS,PUIDX(250),
  3434.      +          SYMBOL(8,5003)
  3435.         LOGICAL MODFLG
  3436.  
  3437.         SAVE /XCSYMS/
  3438. C---------------------------------------------------------
  3439. C    TOOLPACK/1    Release: 2.5
  3440. C---------------------------------------------------------
  3441.         COMMON/XCPAHP/USHEAD,PAHEAD,PAHEAP
  3442.         INTEGER USHEAD,PAHEAD,PAHEAP(11000)
  3443.  
  3444.         SAVE /XCPAHP/
  3445.  
  3446.         INTEGER MTYPE1
  3447.         PARAMETER (MTYPE1=5)
  3448.  
  3449.         INTEGER USREF,GPRSYM,GP,P,I,INHREC(4),PX,COUNT
  3450.         LOGICAL ADDIT
  3451.  
  3452.         INTEGER LLFIRS,LLNEXT,LLCRHE,LLCRED,LLHEAD
  3453.         EXTERNAL LLFIRS,LLNEXT,LLCRHE,LLCRED,LLHEAD,LLINTO
  3454.  
  3455.         USREF=LLFIRS(PAHEAP,USHEAD)
  3456.         IF (USREF.NE.0) THEN
  3457.  100        GPRSYM=SYMATR(SYMBOL(7,
  3458.      +                           PAHEAP(USREF+5))+0)
  3459.             GP=ABS(GPRSYM)
  3460.  200        IF (SYMATR(GP).NE.129) THEN
  3461.                 GP=GP+1
  3462.                 GOTO 200
  3463.             END IF
  3464.             IF (GPRSYM.GT.0) THEN
  3465.                 IF (LLHEAD(SYMATR,GPRSYM).EQ.SYMATR(ATRGLB+0))
  3466.      +          THEN
  3467.                     P=GP+7+
  3468.      +                (PAHEAP(USREF+1)-1)*7+
  3469.      +                6
  3470.                 ELSE
  3471.                     P=GP+6+(PAHEAP(USREF+1)-1)
  3472.                     P=SYMATR(P)+6
  3473.                 END IF
  3474.             ELSE
  3475.                 P=GP+4
  3476.                 DO 300 I=2,PAHEAP(USREF+1)
  3477.                     IF (SYMATR(P)/8+(-3).EQ.6) THEN
  3478.                         P=P+4
  3479.                     ELSE
  3480.                         P=P+2
  3481.                     END IF
  3482.  300            CONTINUE
  3483.                 P=P+1
  3484.             END IF
  3485.             IF (SYMATR(P).EQ.0) SYMATR(P)=LLCRHE(SYMATR,0)
  3486.             INHREC(1+0)=PAHEAP(USREF+0)
  3487.             INHREC(1+1)=SYMATR(
  3488.      +          SYMBOL(8,PAHEAP(USREF+3))+
  3489.      +          SYMBOL(7,PAHEAP(USREF+3))+1)
  3490.             INHREC(1+2)=PAHEAP(USREF+4)
  3491.             IF (PAHEAP(USREF+0).EQ.3) THEN
  3492.                 INHREC(1+3)=
  3493.      +              SYMBOL(8,PAHEAP(USREF+2))
  3494.             ELSE
  3495.                 INHREC(1+3)=PAHEAP(USREF+2)
  3496.             END IF
  3497. C Only add "inherit-expression" record if there is less than MTYPE1 of
  3498. C them already.
  3499.             IF (INHREC(1+0).EQ.1) THEN
  3500.                 PX=LLFIRS(SYMATR,SYMATR(P))
  3501.                 COUNT=0
  3502.                 IF (PX.NE.0) THEN
  3503.  400                IF (SYMATR(PX+0).EQ.1)
  3504.      +                  COUNT=COUNT+1
  3505.                     PX=LLNEXT(SYMATR,PX)
  3506.                     IF (PX.NE.0) GOTO 400
  3507.                 END IF
  3508.                 ADDIT=COUNT.LT.MTYPE1
  3509.             ELSE
  3510.                 ADDIT=.TRUE.
  3511.             END IF
  3512.             IF (ADDIT)
  3513.      +          CALL LLINTO(SYMATR,LLCRED(SYMATR,4,INHREC),
  3514.      +                  SYMATR(P))
  3515.             USREF=LLNEXT(PAHEAP,USREF)
  3516.             IF (USREF.NE.0) GOTO 100
  3517.         END IF
  3518.  
  3519.         END
  3520. C ----------------------------------------------------------------------
  3521. C
  3522. C       $ G E T G _ P U   -   Get a global program-unit attribute block
  3523. C
  3524.  
  3525.         SUBROUTINE ZYXGPU(GPUPTR,NAME,DTYPE,CHRLEN,NARGS,CULIST,DESC,
  3526.      +                      ELIST,ARG)
  3527.         INTEGER GPUPTR,NAME(*),DTYPE,CHRLEN,NARGS,CULIST,DESC,ELIST,
  3528.      +          ARG(0:7-1,*)
  3529.  
  3530. C---------------------------------------------------------
  3531. C    TOOLPACK/1    Release: 2.5
  3532. C---------------------------------------------------------
  3533.         COMMON/XCATRX/SYMATR,ATRGLB
  3534.         INTEGER SYMATR(69000),ATRGLB
  3535.         SAVE /XCATRX/
  3536.  
  3537.         INTEGER I,J,CURDTA
  3538.  
  3539.         INTEGER LENGTH,LLFIRS,LLNEXT
  3540.         EXTERNAL LENGTH,LLFIRS,LLNEXT,SCOPY,ERROR
  3541.  
  3542.         IF (GPUPTR.EQ.-1) THEN
  3543.             IF (SYMATR(ATRGLB+0).EQ.0)
  3544.      +          CALL ERROR('No global attributes found')
  3545.             GPUPTR=LLFIRS(SYMATR,SYMATR(ATRGLB+0))
  3546.         ELSE IF (GPUPTR.EQ.0) THEN
  3547.             CALL ERROR('ZYXGPU: NIL POINTER SUPPLIED')
  3548.         END IF
  3549.         CALL SCOPY(SYMATR,GPUPTR,NAME,1)
  3550.         CURDTA=GPUPTR+LENGTH(NAME)
  3551.         DTYPE=SYMATR(CURDTA+1)
  3552.         CHRLEN=SYMATR(CURDTA+2)
  3553.         CULIST=SYMATR(CURDTA+3)
  3554.         IF (CULIST.NE.0) CULIST=LLFIRS(SYMATR,CULIST)
  3555.         NARGS=SYMATR(CURDTA+4)
  3556.         DESC=SYMATR(CURDTA+5)
  3557.         IF (DESC.NE.0) DESC=LLFIRS(SYMATR,DESC)
  3558.         ELIST=SYMATR(CURDTA+6)
  3559.         IF (ELIST.NE.0) ELIST=LLFIRS(SYMATR,ELIST)
  3560.         CURDTA=CURDTA+7
  3561.         DO 200 I=1,NARGS
  3562.             DO 100 J=0,4
  3563.                 ARG(J,I)=SYMATR(CURDTA+J)
  3564.  100        CONTINUE
  3565.             IF (SYMATR(CURDTA+5).NE.0) THEN
  3566.                 ARG(5,I)=LLFIRS(SYMATR,SYMATR(CURDTA+5))
  3567.             ELSE
  3568.                 ARG(5,I)=0
  3569.             END IF
  3570.             IF (SYMATR(CURDTA+6).NE.0) THEN
  3571.                 ARG(6,I)=LLFIRS(SYMATR,SYMATR(CURDTA+6))
  3572.             ELSE
  3573.                 ARG(6,I)=0
  3574.             END IF
  3575.             CURDTA=CURDTA+7
  3576.  200    CONTINUE
  3577.         GPUPTR=LLNEXT(SYMATR,GPUPTR)
  3578.  
  3579.         END
  3580. C ----------------------------------------------------------------------
  3581. C
  3582. C       $ G E T G _ P A S S   -   Get a passage record for a p.u. arg
  3583. C
  3584.  
  3585.         SUBROUTINE ZYXGPA(PASSX,ARGNUM,DESREC)
  3586.         INTEGER PASSX,ARGNUM,DESREC
  3587.  
  3588.  
  3589. C---------------------------------------------------------
  3590. C    TOOLPACK/1    Release: 2.5
  3591. C---------------------------------------------------------
  3592.         COMMON/XCATRX/SYMATR,ATRGLB
  3593.         INTEGER SYMATR(69000),ATRGLB
  3594.         SAVE /XCATRX/
  3595.  
  3596.         INTEGER LLNEXT
  3597.         EXTERNAL ERROR,LLNEXT
  3598.  
  3599.         IF (PASSX.LE.0) CALL ERROR('ZYXGPA: Invalid Argument')
  3600.         ARGNUM=SYMATR(PASSX)
  3601.         DESREC=SYMATR(PASSX+1)
  3602.         PASSX=LLNEXT(SYMATR,PASSX)
  3603.  
  3604.         END
  3605. C ----------------------------------------------------------------------
  3606. C
  3607. C       $ G E T G _ C U D A T A   -   Get common usage list entry data
  3608. C
  3609.  
  3610.         SUBROUTINE ZYXGCU(CULIST,GCBPTR,USAGE)
  3611.         INTEGER CULIST,GCBPTR,USAGE
  3612.  
  3613. C---------------------------------------------------------
  3614. C    TOOLPACK/1    Release: 2.5
  3615. C---------------------------------------------------------
  3616.         COMMON/XCATRX/SYMATR,ATRGLB
  3617.         INTEGER SYMATR(69000),ATRGLB
  3618.         SAVE /XCATRX/
  3619.  
  3620.         INTEGER LLNEXT
  3621.         EXTERNAL LLNEXT
  3622.  
  3623.         GCBPTR=SYMATR(CULIST)
  3624.         USAGE=SYMATR(CULIST+1)
  3625.         CULIST=LLNEXT(SYMATR,CULIST)
  3626.  
  3627.         END
  3628. C ----------------------------------------------------------------------
  3629. C
  3630. C       $ G E T G _ D E S C   -   Get program-unit descendant data
  3631. C
  3632.  
  3633.         SUBROUTINE ZYXGGD(DESC,REFTYP,GSYPTR,ARGNUM)
  3634.         INTEGER DESC,REFTYP,GSYPTR,ARGNUM
  3635.  
  3636. C---------------------------------------------------------
  3637. C    TOOLPACK/1    Release: 2.5
  3638. C---------------------------------------------------------
  3639.         COMMON/XCATRX/SYMATR,ATRGLB
  3640.         INTEGER SYMATR(69000),ATRGLB
  3641.         SAVE /XCATRX/
  3642.  
  3643.         INTEGER LLNEXT
  3644.         EXTERNAL LLNEXT
  3645.  
  3646.         REFTYP=SYMATR(DESC)
  3647.         GSYPTR=SYMATR(DESC+1)
  3648.         ARGNUM=SYMATR(DESC+2)
  3649.         DESC=LLNEXT(SYMATR,DESC)
  3650.  
  3651.         END
  3652. C ----------------------------------------------------------------------
  3653. C
  3654. C       $ G E T G _ E N T _ P T R   -   Get global ENTRY point pointer
  3655. C
  3656.  
  3657.         SUBROUTINE ZYXGEP(ELIST,ENTPTR)
  3658.         INTEGER ELIST,ENTPTR
  3659.  
  3660. C---------------------------------------------------------
  3661. C    TOOLPACK/1    Release: 2.5
  3662. C---------------------------------------------------------
  3663.         COMMON/XCATRX/SYMATR,ATRGLB
  3664.         INTEGER SYMATR(69000),ATRGLB
  3665.         SAVE /XCATRX/
  3666.  
  3667.         INTEGER LLNEXT
  3668.         EXTERNAL LLNEXT
  3669.  
  3670.         ENTPTR=SYMATR(ELIST)
  3671.         ELIST=LLNEXT(SYMATR,ELIST)
  3672.  
  3673.         END
  3674. C ----------------------------------------------------------------------
  3675. C
  3676. C       $ G E T G _ E N T R Y   -   Get a global ENTRY point record
  3677. C
  3678.  
  3679.         SUBROUTINE ZYXGEN(GENPTR,NAME,DTYPE,CHRLEN,NARGS,GPU,DESC,
  3680.      +                         ARG)
  3681.         INTEGER GENPTR,NAME(*),DTYPE,CHRLEN,NARGS,GPU,DESC,
  3682.      +          ARG(0:7-1,*)
  3683.  
  3684. C---------------------------------------------------------
  3685. C    TOOLPACK/1    Release: 2.5
  3686. C---------------------------------------------------------
  3687.         COMMON/XCATRX/SYMATR,ATRGLB
  3688.         INTEGER SYMATR(69000),ATRGLB
  3689.         SAVE /XCATRX/
  3690.  
  3691.         INTEGER I,J,CURDTA,ARGX
  3692.  
  3693.         INTEGER LENGTH,LLFIRS,LLNEXT
  3694.         EXTERNAL LENGTH,LLFIRS,LLNEXT,ERROR,SCOPY
  3695.  
  3696.         IF (GENPTR.EQ.-1) THEN
  3697.             IF (SYMATR(ATRGLB+3).EQ.0) RETURN
  3698.             GENPTR=LLFIRS(SYMATR,SYMATR(ATRGLB+3))
  3699.         ELSE IF (GENPTR.EQ.0) THEN
  3700.             CALL ERROR('ZYXGEN: NIL POINTER SUPPLIED')
  3701.         END IF
  3702.         CALL SCOPY(SYMATR,GENPTR,NAME,1)
  3703.         CURDTA=GENPTR+LENGTH(NAME)
  3704.         DTYPE=SYMATR(CURDTA+1)
  3705.         CHRLEN=SYMATR(CURDTA+2)
  3706.         NARGS=SYMATR(CURDTA+4)
  3707.         GPU=SYMATR(CURDTA+3)
  3708.         DESC=SYMATR(CURDTA+5)
  3709.         IF (DESC.NE.0) DESC=LLFIRS(SYMATR,DESC)
  3710.         CURDTA=CURDTA+6
  3711.         DO 200 I=1,NARGS
  3712.             ARGX=SYMATR(CURDTA+I-1)
  3713.             DO 100 J=0,4
  3714.                 ARG(J,I)=SYMATR(ARGX+J)
  3715.  100        CONTINUE
  3716.             IF (SYMATR(ARGX+5).NE.0) THEN
  3717.                 ARG(5,I)=LLFIRS(SYMATR,SYMATR(ARGX+5))
  3718.             ELSE
  3719.                 ARG(5,I)=0
  3720.             END IF
  3721.             IF (SYMATR(ARGX+6).NE.0) THEN
  3722.                 ARG(6,I)=LLFIRS(SYMATR,SYMATR(ARGX+6))
  3723.             ELSE
  3724.                 ARG(6,I)=0
  3725.             END IF
  3726.  200    CONTINUE
  3727.         GENPTR=LLNEXT(SYMATR,GENPTR)
  3728.  
  3729.         END
  3730. C ----------------------------------------------------------------------
  3731. C
  3732. C       $ G E T G _ C O M   -   Get a global common block attr block
  3733. C
  3734.  
  3735.         SUBROUTINE ZYXGCB(GCBPTR,NAME,COMLEN,COMTYP,COMSAV,
  3736.      +                             COMINI)
  3737.         INTEGER GCBPTR,NAME(*),COMLEN,COMTYP,COMSAV,COMINI
  3738.  
  3739. C---------------------------------------------------------
  3740. C    TOOLPACK/1    Release: 2.5
  3741. C---------------------------------------------------------
  3742.         COMMON/XCATRX/SYMATR,ATRGLB
  3743.         INTEGER SYMATR(69000),ATRGLB
  3744.         SAVE /XCATRX/
  3745.  
  3746.         INTEGER CURDTA
  3747.  
  3748.         INTEGER LENGTH,LLFIRS,LLNEXT
  3749.         EXTERNAL LENGTH,LLFIRS,LLNEXT,SCOPY,ERROR
  3750.  
  3751.         IF (GCBPTR.EQ.-1) THEN
  3752.             IF (SYMATR(ATRGLB+1).EQ.0) RETURN
  3753.             GCBPTR=LLFIRS(SYMATR,SYMATR(ATRGLB+1))
  3754.         ELSE IF (GCBPTR.EQ.0) THEN
  3755.             CALL ERROR('ZYXGCB: NIL POINTER SUPPLIED')
  3756.         END IF
  3757.         CALL SCOPY(SYMATR,GCBPTR,NAME,1)
  3758.         CURDTA=GCBPTR+LENGTH(NAME)
  3759.         COMLEN=SYMATR(CURDTA+1)
  3760.         COMTYP=SYMATR(CURDTA+2)
  3761.         COMSAV=SYMATR(CURDTA+3)
  3762.         COMINI=SYMATR(CURDTA+4)
  3763.         GCBPTR=LLNEXT(SYMATR,GCBPTR)
  3764.  
  3765.         END
  3766. C ----------------------------------------------------------------------
  3767. C
  3768. C       $ G E T G _ E X T   -   Get a global external reference atr blk
  3769. C
  3770.  
  3771.         SUBROUTINE ZYXGEX(GEXPTR,NAME,DTYPE,CHRLEN,NARGS,ARGBLK)
  3772.         INTEGER GEXPTR,NAME(*),DTYPE,CHRLEN,NARGS,ARGBLK(*)
  3773.  
  3774. C---------------------------------------------------------
  3775. C    TOOLPACK/1    Release: 2.5
  3776. C---------------------------------------------------------
  3777.         COMMON/XCATRX/SYMATR,ATRGLB
  3778.         INTEGER SYMATR(69000),ATRGLB
  3779.         SAVE /XCATRX/
  3780.  
  3781.         INTEGER I,J,CURDTA
  3782.  
  3783.         INTEGER LENGTH,LLFIRS,LLNEXT
  3784.         EXTERNAL LENGTH,LLFIRS,LLNEXT,ERROR,SCOPY
  3785.  
  3786.         IF (GEXPTR.EQ.-1) THEN
  3787.             IF (SYMATR(ATRGLB+2).EQ.0) RETURN
  3788.             GEXPTR=LLFIRS(SYMATR,SYMATR(ATRGLB+2))
  3789.         ELSE IF (GEXPTR.EQ.0) THEN
  3790.             CALL ERROR('ZYXGEX: NIL POINTER SUPPLIED')
  3791.         END IF
  3792.         CALL SCOPY(SYMATR,GEXPTR,NAME,1)
  3793.         CURDTA=GEXPTR+LENGTH(NAME)
  3794.         DTYPE=SYMATR(CURDTA+1)
  3795.         CHRLEN=SYMATR(CURDTA+2)
  3796.         NARGS=SYMATR(CURDTA+3)
  3797.         CURDTA=CURDTA+4-1
  3798.         J=1
  3799.         DO 100 I=1,NARGS
  3800.             ARGBLK(J+0)=SYMATR(CURDTA+J+0)
  3801.             ARGBLK(J+1)=SYMATR(CURDTA+J+1)
  3802.             IF (ARGBLK(J+1).NE.0)
  3803.      +          ARGBLK(J+1)=LLFIRS(SYMATR,ARGBLK(J+1))
  3804.             IF (ARGBLK(J+0)/8+(-3).EQ.6) THEN
  3805.                 ARGBLK(J+2)=SYMATR(CURDTA+J+2)
  3806.                 ARGBLK(J+3)=SYMATR(CURDTA+J+3)
  3807.                 J=J+4
  3808.             ELSE
  3809.                 J=J+2
  3810.             END IF
  3811.  100    CONTINUE
  3812.         GEXPTR=LLNEXT(SYMATR,GEXPTR)
  3813.  
  3814.         END
  3815. C ----------------------------------------------------------------------
  3816. C
  3817. C       $ G E T G _ N A M E   -   Get global name
  3818. C
  3819.  
  3820.         SUBROUTINE ZYXGNA(NAMPTR,NAME)
  3821.         INTEGER NAMPTR,NAME(*)
  3822.  
  3823. C---------------------------------------------------------
  3824. C    TOOLPACK/1    Release: 2.5
  3825. C---------------------------------------------------------
  3826.         COMMON/XCATRX/SYMATR,ATRGLB
  3827.         INTEGER SYMATR(69000),ATRGLB
  3828.         SAVE /XCATRX/
  3829.  
  3830.         EXTERNAL SCOPY
  3831.  
  3832.         CALL SCOPY(SYMATR,NAMPTR,NAME,1)
  3833.  
  3834.         END
  3835. C ----------------------------------------------------------------------
  3836. C
  3837. C       $ G E T G _ I D X _ P U   -   Get global program-unit index
  3838. C
  3839. C       Negative results are minus entry point index values.
  3840. C
  3841.  
  3842.         INTEGER FUNCTION ZYXGIP(GPUPTR)
  3843.         INTEGER GPUPTR
  3844.  
  3845. C---------------------------------------------------------
  3846. C    TOOLPACK/1    Release: 2.5
  3847. C---------------------------------------------------------
  3848.         COMMON/XCATRX/SYMATR,ATRGLB
  3849.         INTEGER SYMATR(69000),ATRGLB
  3850.         SAVE /XCATRX/
  3851.  
  3852.         INTEGER PTR
  3853.  
  3854.         INTEGER LLFIRS,LLNEXT
  3855.         EXTERNAL LLFIRS,LLNEXT,ERROR
  3856.  
  3857.         ZYXGIP=1
  3858.         PTR=LLFIRS(SYMATR,SYMATR(ATRGLB+0))
  3859.  100    IF (PTR.EQ.GPUPTR) RETURN
  3860.         PTR=LLNEXT(SYMATR,PTR)
  3861.         ZYXGIP=ZYXGIP+1
  3862.         IF (PTR.NE.0) GOTO 100
  3863. C Didn't find it there - try the ENTRY point list
  3864.         ZYXGIP=-1
  3865.         PTR=LLFIRS(SYMATR,SYMATR(ATRGLB+3))
  3866.  200    IF (PTR.EQ.GPUPTR) RETURN
  3867.         PTR=LLNEXT(SYMATR,PTR)
  3868.         ZYXGIP=ZYXGIP-1
  3869.         IF (PTR.NE.0) GOTO 200
  3870.         CALL ERROR('ZYXGIP: Couldn''t find program unit')
  3871.  
  3872.         END
  3873. C ----------------------------------------------------------------------
  3874. C
  3875. C       $ G E T G _ I D X _ C B   -   Get global common-block index
  3876. C
  3877.  
  3878.         INTEGER FUNCTION ZYXGIC(GCBPTR)
  3879.         INTEGER GCBPTR
  3880.  
  3881. C---------------------------------------------------------
  3882. C    TOOLPACK/1    Release: 2.5
  3883. C---------------------------------------------------------
  3884.         COMMON/XCATRX/SYMATR,ATRGLB
  3885.         INTEGER SYMATR(69000),ATRGLB
  3886.         SAVE /XCATRX/
  3887.  
  3888.         INTEGER PTR
  3889.  
  3890.         INTEGER LLFIRS,LLNEXT
  3891.         EXTERNAL LLFIRS,LLNEXT,ERROR
  3892.  
  3893.         ZYXGIC=1
  3894.         PTR=LLFIRS(SYMATR,SYMATR(ATRGLB+1))
  3895.  100    IF (PTR.EQ.GCBPTR) RETURN
  3896.         PTR=LLNEXT(SYMATR,PTR)
  3897.         ZYXGIC=ZYXGIC+1
  3898.         IF (PTR.NE.0) GOTO 100
  3899.         CALL ERROR('ZYXGIC: Couldn''t find common block')
  3900.  
  3901.         END
  3902. C ----------------------------------------------------------------------
  3903. C
  3904. C       $ G E T G _ I D X _ E X   -   Get global external ref index
  3905. C
  3906.  
  3907.         INTEGER FUNCTION ZYXGIE(GEXPTR)
  3908.         INTEGER GEXPTR
  3909.  
  3910. C---------------------------------------------------------
  3911. C    TOOLPACK/1    Release: 2.5
  3912. C---------------------------------------------------------
  3913.         COMMON/XCATRX/SYMATR,ATRGLB
  3914.         INTEGER SYMATR(69000),ATRGLB
  3915.         SAVE /XCATRX/
  3916.  
  3917.         INTEGER PTR
  3918.  
  3919.         INTEGER LLFIRS,LLNEXT
  3920.         EXTERNAL LLFIRS,LLNEXT,ERROR
  3921.  
  3922.         ZYXGIE=1
  3923.         PTR=LLFIRS(SYMATR,SYMATR(ATRGLB+2))
  3924.  100    IF (PTR.EQ.GEXPTR) RETURN
  3925.         PTR=LLNEXT(SYMATR,PTR)
  3926.         ZYXGIE=ZYXGIE+1
  3927.         IF (PTR.NE.0) GOTO 100
  3928.         CALL ERROR('ZYXGIE: Couldn''t find external ref')
  3929.  
  3930.         END
  3931. C ----------------------------------------------------------------------
  3932. C
  3933. C       $ G E T G _ I N H R E C   -   Get global argument inheritance
  3934. C
  3935.  
  3936.         SUBROUTINE ZYXGIR(INHREC,INHTYP,ASSOC,STMTNO,EXTRA)
  3937.         INTEGER INHREC,INHTYP,ASSOC,STMTNO,EXTRA
  3938.  
  3939. C---------------------------------------------------------
  3940. C    TOOLPACK/1    Release: 2.5
  3941. C---------------------------------------------------------
  3942.         COMMON/XCATRX/SYMATR,ATRGLB
  3943.         INTEGER SYMATR(69000),ATRGLB
  3944.         SAVE /XCATRX/
  3945.  
  3946.         INTEGER LLNEXT
  3947.         EXTERNAL ERROR,LLNEXT
  3948.  
  3949.         IF (INHREC.LE.0) CALL ERROR('ZYXGIR: Invalid argument')
  3950.         INHTYP=SYMATR(INHREC+0)
  3951.         ASSOC=SYMATR(INHREC+1)
  3952.         STMTNO=SYMATR(INHREC+2)
  3953.         EXTRA=SYMATR(INHREC+3)
  3954.         INHREC=LLNEXT(SYMATR,INHREC)
  3955.  
  3956.         END
  3957. C ----------------------------------------------------------------------
  3958. C
  3959. C       X $ P R O C _ T Y P C   -   Procedure type compatibility
  3960. C
  3961.  
  3962.         INTEGER FUNCTION XZYTPC(TYP1,TYP2)
  3963.         INTEGER TYP1,TYP2
  3964.  
  3965.         INTEGER COMTYP(0:4,0:4)
  3966.  
  3967.         SAVE COMTYP
  3968.  
  3969. C COMTYP(newtype,oldtype)=actual type or -1 for invalid combinations
  3970.  
  3971.         DATA COMTYP/ 0, 0,-1,-1,-1,
  3972.      +               0, 1, 2,-1,-1,
  3973.      +              -1, 2, 2,-1,-1,
  3974.      +              -1,-1,-1, 3,-1,
  3975.      +              -1,-1,-1,-1, 4/
  3976.  
  3977.         XZYTPC=COMTYP(TYP1,TYP2)
  3978.  
  3979.         END
  3980. C ----------------------------------------------------------------------
  3981. C
  3982. C       X $ A L L O C _ A T R   -   (Internal) allocate an attribute blk
  3983. C
  3984.  
  3985.         INTEGER FUNCTION XZYAAB(SIZE)
  3986.         INTEGER SIZE
  3987.  
  3988. C---------------------------------------------------------
  3989. C    TOOLPACK/1    Release: 2.5
  3990. C---------------------------------------------------------
  3991.         COMMON/XCATRX/SYMATR,ATRGLB
  3992.         INTEGER SYMATR(69000),ATRGLB
  3993.         SAVE /XCATRX/
  3994.  
  3995.         INTEGER I
  3996.  
  3997.         INTEGER HGET1,HALLOC
  3998.         EXTERNAL HGET1,HALLOC
  3999.  
  4000.         IF (SIZE.EQ.1) THEN
  4001.             XZYAAB=HGET1(SYMATR)
  4002.         ELSE
  4003.             XZYAAB=HALLOC(SYMATR,SIZE)
  4004.         END IF
  4005.         DO 100 I=XZYAAB,XZYAAB+SIZE-1
  4006.             SYMATR(I)=0
  4007.  100    CONTINUE
  4008.  
  4009.         END
  4010. C ----------------------------------------------------------------------
  4011. C
  4012. C       $ C H K _ A S T R U C T   -   Check argument structure
  4013. C
  4014.  
  4015.         LOGICAL FUNCTION ZYXCAS(STRUCT,ATYPE)
  4016.         INTEGER STRUCT,ATYPE
  4017.  
  4018. C Arg: If proc, must match proc
  4019.         IF (STRUCT.EQ.2 .NEQV. ATYPE.EQ.3 .OR.
  4020. C Arg: array must match array/arelm
  4021.      +      STRUCT.EQ.1 .AND. ATYPE.NE.1 .AND.
  4022.      +                                   ATYPE.NE.2 .OR.
  4023.      +      STRUCT.NE.1 .AND. ATYPE.EQ.2) THEN
  4024.             ZYXCAS=.FALSE.
  4025.         ELSE
  4026.             ZYXCAS=.TRUE.
  4027.         END IF
  4028.  
  4029.         END
  4030.